Internet Info 1994 March

home *** CD-ROM | disk | FTP | other *** search

/ Internet Info 1994 March / Internet Info CD-ROM (Walnut Creek) (March 1994).iso / networking / terms / kermit / b / iktutl.asm < prev next >

Wrap

Assembly Source File | 1992-09-29 | 170.5 KB | 2,156 lines

*COPY IKTUTL 05000000 CHECKVER IKTUTL,4.2 @SC90072 05000500 TITLE 'CWDSET/DSPACE Routines - set/show working directory' 05001000 * Set new 'working directory', i.e., DSN prefix 05002000 * Entry: SCANPTR string has option 05003000 * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged. 05004000 CWDSET ENTER @SC86164 05005000 SR 5,5 @SC86299 05006000 MVI IFILE+44,C' ' @SC86299 05007000 NTOKN N=CWDLEN,H=CWDERR @SC86299 05008000 LA 1,0(7,6) End of string @SC86299 05009000 BCTR 1,0 @SC86299 05010000 CLC =C'()',0(1) Prefix is PDS name? @SC86299 05011000 BNE CWDTL No @SC86299 05012000 S 7,F2 Yes, remove null member name @SC86299 05013000 BM CWDERR @SC86299 05014000 MVI IFILE+44,C'.' Indicate PDS wanted @SC86299 05015000 CWDTL LA 7,1(7) Token length @SC86299 05016000 CH 7,LA44+2 Suitable? @SC86299 05017000 BH CWDERR Too long @SC86299 05018000 LR 5,7 @SC86299 05019000 ICM 7,8,BLANK @SC86299 05020000 LA 0,IFILE @SC86299 05021000 LA44 LA 1,44 Length of DSN alone @SC86299 05022000 MVCL 0,6 Copy to filename buffer @SC86299 05023000 TR IFILE,UPCASE And upcase it @SC87034 05024000 NXTFSET IFILE,CWD,E=CWDERR @SC86295 05025000 CWDLEN MVC DEST(45),IFILE Save new prefix @SC86299 05026000 STH 5,DESTL @SC86299 05027000 B RTRN0 @SC86295 05028000 CWDERR PTEXT 'Must be valid file prefix' @SC86299 05029000 B SUBERR @SC86295 05030000 * 05031000 * DSPACE Routine - display available disk space @SC86164 05032000 * 05033000 * Show space available in 'working directory' or other area 05034000 * Entry: SCANPTR string has option (none => working directory) 05035000 * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged 05036000 DSPACE ENTER ALT @SC86164 05037000 * * * * * * * * * * * * * * * * * * * * * * 05038000 PTEXT 'SPACE not implemented' @SC86299 05039000 B SUBERR @SC86299 05040000 * * * * * * * * * * * * * * * * * * * * * * 05041000 B RTRN0 @SC86295 05042000 LOCALS , @SC86295 05043000 EXIT , @SC86295 05044000 TITLE 'FSPEC Routine - extract filespec from scan string' 05045000 * 05046000 * Entry: R1->name field, R0=flags selecting operation (see below) 05047000 * For parse operations, SCANPTR defines the input string. 05048000 * For getting foreign or display filespec, R7->output buffer 05049000 * Exit: if not FFNEW, then R15=0 if ok, 1 if ?, 2 if bad. 05050000 * For R15=1 or 2 R3,R4 give message. ERRNUM may be leftover. 05051000 * 05052000 * Flags: Notes: 05053000 * Tasks: FFRCF FFSND FFGET FFNEW 05054000 * Parse RECV X set ROVR properly 05055000 * Parse SEND 1st X 05056000 * Parse SEND 2nd X X 05057000 * Parse GET 1st X 05058000 * Parse GET 2nd X X set ROVR properly 05059000 * Parse F-packet (FFHDR) X X X 05060000 * Parse for Generic(FFUTL) X X FFWLD: allow partial 05061000 * Parse TAKE 05062000 * 05063000 * Get unique name X R15: 0=>ok, 1=>bad 05064000 * Interactive name check X X R15: 0=>ok, 1=>bad 05065000 * Get foreign name (FFENC) X X R15->end of string 05066000 * Get display form (FFDSP) X X R15->end of string 05067000 * 05068000 FSPEC ENTER @SC86295 05069000 STC 0,FSPFLG @SC86295 05070000 LR 5,0 @SC88049 05070200 SRL 5,4 Convert flags to index @SC88049 05070400 LR 0,1 Copy ptr to filespec @SC86295 05071000 TM FSPFLG,FFNEW @SC86295 05072000 BO FSPWRN @SC86295 05073000 LR 8,1 Save ptr to DSN field @SC86299 05074000 XC 0(52,8),0(8) Clear DSN field @SC86299 05075000 MVC 52(8,8),=CL8' ' Clear password @SC88342 05075500 PTEXT 'Invalid DSN' @SC86299 05076000 MVI ERRNUM,ERRFNE Assume bad file name @SC86158 05077000 IC 5,FSP0(5) Get dispatch adr @SC88049 05078000 B FSP0(5) Go to proper handler @SC88049 05078500 * TAKE GET 1st SEND 1st Generic @SC88049 05079000 FSP0 DC AL1(FSPCPY-FSP0,FSPSN2-FSP0,FSPASC-FSP0,FSPUTL-FSP0) SC88049 05079500 * RECEIVE GET 2nd SEND 2nd F-packet @SC88049 05080000 DC AL1(FSPRC-FSP0,FSPRC-FSP0,FSPSN2-FSP0,FSPHD-FSP0) @SC88049 05080500 FSPUTL TM FSPFLG,FFWLD Utility: default to all files? @SC88049 05081000 BZ FSPASC No @SC86295 05083000 LA 1,LFID @SC88043 05084000 LA 14,DEST Default to prefix @SC88043 05084300 LH 15,DESTL @SC88043 05084600 BAL 2,FSPBPAD Copy with blank fill @SC88070 05084900 LR 0,8 Restore ptr to name field @SC88043 05085500 FSPASC TM FL2,SRV Server mode? @SC86295 05086000 BZ FSPCPY No, don't need to convert @SC86295 05087000 ICM 15,15,LEN Get length @SC86295 05088000 BZ FSPCPY @SC86295 05089000 BCTR 15,0 Correct for EX @SC86158 05090000 L 5,ADR Get string ptr @SC89215 05091000 EX 15,FSPTRAE Change to EBCDIC @SC89215 05092000 EX 15,FSPTRUP Upcase and dot to space @SC89215 05093000 B FSPCPY @SC86295 05094000 FSPTRAE TR 0(,5),ATOED @SC89301 05095000 FSPTRUP TR 0(,5),UPCASE @SC89215 05096000 FSPRC NI FL1,255-ROVR Setup for RECEIVE @SC86295 05099000 NI FL4,255-NMOK-NMCHNG Collision not checked yet @SC90033 05100000 MVI 0(1),C'$' Allow missing DSN @SC86299 05101000 B FSPCPY @SC86295 05102000 FSPHD MVI 0(1),1 Use default if missing DSN @SC86299 05103000 B FSPCPY @SC86299 05104000 FSPSN2 CLI BRK,C',' @SC88306 05110000 BE RTRN0 No foreign name: multiple format @SC88306 05110300 NTOKN H=FSP2H,N=RTRN0 @SC88306 05110600 LA 7,1(,7) Get token length @SC89179 05110800 LA 1,L'JFNAM @SC86295 05111000 CR 7,1 Does it fit? @SC89179 05112000 BNH *+6 Yes @SC86224 05113000 LR 7,1 Use what we can @SC86224 05114000 LR 3,0 @SC86295 05115000 STC 7,0(3) Save length @SC86224 05116000 LA 0,1(3) @SC86295 05117000 MVCL 0,6 Get fn, at least @SC86224 05118000 B RTRN0 @SC86295 05119000 * 05120000 FSPSLSH TRT 0(,6),FSPTRSL Find slash, if any @SC88342 05120200 FSPPSMV MVC 52(,8),1(1) Copy password into field @SC88342 05120400 * 05120600 FSPCPY NTOKN H=FSPH,N=FSPZ @SC86299 05121000 FSPCP2 MVC FSPCH1,0(6) Save 1st char @SC88043 05122000 MVI TRTBL+C'.',1 Set to intercept these @SC88043 05122500 MVI TRTBL+C'(',2 @SC86299 05123000 KCALL FOPSTR,LFID(,8),E=FSPINV @SC89218 05123100 LR 2,7 Save length-1 @SC88342 05123500 LA 15,44 Length of DSN proper @SC86299 05124000 AR 7,6 Last char of string @SC86299 05125000 LR 1,7 @SC88342 05125070 EX 2,FSPSLSH Look for '/' @SC88342 05125140 BZ FSPPSZ No password @SC88342 05125210 SR 7,1 Get length @SC88342 05125280 BNP FSPPSY None after all @SC88342 05125350 CH 7,*+10 Check against maximum @SC88342 05125420 BNH *+8 Ok @SC88342 05125490 LA 7,8 Max length @SC88342 05125560 BCTR 7,0 Prepare for MVC @SC88342 05125630 EX 7,FSPPSMV Move password to output field @SC88342 05125700 FSPPSY LR 7,1 Remove password from string @SC88342 05125770 BCTR 7,0 Remove '/' too @SC88342 05125840 FSPPSZ DS 0H @SC88342 05125910 CLI 0(6),C'''' Full name? @SC86299 05126000 BNE FSPPRE No, add prefix @SC86299 05127000 LA 6,1(6) Yes, skip over quote @SC86299 05128000 CLI 0(7),C'''' Must have close quote as well @SC86299 05129000 BNE *+6 @SC86299 05130000 BCTR 7,0 Back up over it @SC86299 05131000 BE *+8 @SC86299 05132000 BAL 9,FSPTU Missing: quit if user typed this @SC86299 05133000 B FSPPREZ @SC86299 05134000 FSPPRE CLI 0(7),C'''' Better not be trailing quote @SC86299 05135000 BNE *+10 Ok @SC86299 05136000 BAL 9,FSPTU Error @SC86299 05137000 BCTR 7,0 Didn't quit, so patch it up @SC86299 05138000 LH 1,DESTL Length of prefix @SC86299 05139000 LTR 1,1 Any? @SC86299 05140000 BZ FSPPREZ No @SC86299 05141000 LA 14,DEST Ptr to prefix string @SC86299 05142000 MVCL 0,14 Copy prefix to name field @SC86299 05143000 CLI DESTP,C'.' PDS? @SC86299 05144000 BNE FSPDOT No, join with a dot @SC88070 05145000 BAL 2,FSPBFIL Yes, prefix is entire DSN @SC88070 05145100 TM FSPFLG,FFHDR Reading from header packet? @SC88070 05145200 BNO FSPCPP No, user must have entered it @SC88070 05145300 BAL 9,FSPFDOT Ok, find file type, if any @SC88070 05145400 LR 7,1 And skip it @SC88070 05145500 B FSPCPG @SC88070 05145600 FSPDOT LA 14,LOCASE+C'.' @SC86299 05146000 LA 1,1 @SC86299 05147000 MVCL 0,14 Append a dot @SC86299 05148000 FSPPREZ BAL 2,FSPANAT Add '#' if numeric char next @SC86299 05149000 FSPCPA BAL 9,FSPFDOT Find a break (dot or end) @SC88070 05150000 SR 1,6 Length of token @SC86299 05155000 BP *+8 @SC86299 05156000 BAL 9,FSPTU Null token @SC86299 05157000 LR 14,6 Save start of token @SC86299 05158000 AR 6,1 Ptr to break @SC86299 05159000 CR 1,5 Max allowed for this token @SC86299 05160000 BNH *+10 Ok @SC86299 05161000 BAL 9,FSPTU Too long @SC86299 05162000 LR 1,5 Use max @SC86299 05163000 CR 1,15 Room left in name field? @SC86299 05164000 BNH FSPCPC Ok @SC86299 05165000 BAL 9,FSPTU Overfilled @SC86299 05166000 MVI TRTBL+C'.',0 Keep going, but ignore further tok@SC86299 05167000 LR 1,15 @SC86299 05168000 FSPCPC MVCL 0,14 Copy token @SC86299 05169000 BCT 2,FSPCPF Go if reached end of name @SC86299 05170000 LA 6,1(6) Skip over dot @SC86299 05171000 CR 6,7 Was dot the last char? @SC86299 05172000 BH FSPCPE Yes, oops @SC86299 05173000 C 15,F1 Room for another token? @SC86299 05174000 BH FSPDOT Ok, keep going @SC86299 05175000 SR 5,5 No, suppress further tokens @SC86299 05176000 BAL 9,FSPTU Quit if user typed it @SC86299 05177000 B FSPCPA Keep going @SC86299 05178000 FSPTRT TRT 0(,6),TRTBL Find end of token @SC86299 05179000 FSPCPE BAL 9,FSPTU Quit if user type it @SC86299 05180000 FSPCPF BAL 2,FSPBFIL Fill the rest with blanks @SC88070 05181000 BCTR 6,0 Back up to last char of DSN @SC86299 05188000 CR 6,7 @SC86299 05189000 BE FSPCPG No member name @SC86299 05190000 LA 6,2(6) Ptr to member name @SC86299 05191000 CLI 0(7),C')' Must be matching paren @SC86299 05192000 BE FSPCPG Ok @SC86299 05193000 BAL 9,FSPTU Oops @SC86299 05194000 FSPCPP LA 7,1(7) Pretend it's there @SC86299 05195000 FSPCPG SR 7,6 Length of member name @SC86299 05196000 LA 15,8 Length of member name, if any @SC88070 05196500 BZ FSPCPM None, forget it @SC86299 05197000 BAL 2,FSPANAT '#' if numeric char next @SC86299 05199000 FSPCPM LR 14,0 @SC86299 05200000 ICM 7,8,BLANK @SC86299 05201000 MVCL 14,6 Copy member name @SC86299 05202000 CLM 7,7,F0 Did it fit? @SC86299 05203000 BE *+8 @SC86299 05204000 BAL 9,FSPTU Oops @SC86299 05205000 MVC FSPDSN,0(8) Save raw name @SC86299 05206000 TR FSPDSN,UPCASE Upcase it @SC87034 05207000 TR 0(52,8),FSPTAB Convert to valid chars, if nec. @SC86299 05208000 TR 44(8,8),FSPMTAB Stricter limits on member name @SC86299 05209000 TR 52(8,8),UPCASE Upcase password, if any @SC88342 05209050 CLI FSPFLG,FFUTL DELETE? @SC88096 05209100 BE FSPTCNV Yes, allow '*' @SC88096 05209200 CLI FSPFLG,FFSND Send request? @SC88096 05209300 BE FSPTCNV Yes, allow '*' @SC88096 05209400 TR 0(52,8),FSPSTAB Convert asterisk to pound sign @SC88096 05209500 FSPTCNV DS 0H @SC88096 05209600 CLC FSPDSN,0(8) Any conversions? @SC86299 05210000 BE *+8 No, ok @SC86299 05211000 BAL 9,FSPTU Yes, quit if user typed it @SC86299 05212000 OI FL1,ROVR Found a name @SC86299 05213000 MVI TRTBL+C'.',0 Restore table @SC86299 05214000 MVI TRTBL+C'(',0 @SC86299 05215000 TM FSPFLG,FFHDR Parse for TAKE? @SC88043 05215050 BNZ RTRN0 No, fine @SC88043 05215100 CLI FSPCH1,C'''' Fully qualified? @SC88043 05215150 BE RTRN0 Yes, honor it @SC88043 05215200 LA 1,44(8) No, find end of name @SC88043 05215250 LR 14,1 @SC88043 05215300 TRT 0(44,8),TRTBL Get ptr to end+1 in R1 @SC88043 05215350 SR 14,1 Length remaining @SC88043 05215400 CH 14,=H'5' @SC88043 05215450 BL RTRN0 Too short anyway @SC88043 05215500 S 1,F8 @SC88043 05215550 CLC 0(8,1),DKERMINI Is it .KERMINI? @SC88113 05215600 BE RTRN0 Yes, that's ok @SC88043 05215650 CLC =C'.TAKE',3(1) Or is is .TAKE? @SC88043 05215700 BE RTRN0 That's ok too @SC88043 05215750 MVC 8(5,1),=C'.TAKE' No, use default type @SC88043 05215800 B RTRN0 @SC87034 05216000 * 05217000 FSPZ LA 6,=C'$.$' In case we must use default @SC87338 05218000 LA 7,3-1 @SC87338 05219000 CLI 0(8),1 @SC86299 05220000 BE FSPCP2 Get default DSN 'prefix.$.$' @SC87338 05221000 BH RTRN0 Don't insist @SC86299 05222000 PTEXT 'Missing DSN' @SC86299 05223000 B FSPINV @SC86299 05224000 FSPTU TM FSPFLG,FFHDR @SC86299 05225000 BOR 9 From other Kermit, accept it @SC86299 05226000 FSPINV MVI TRTBL+C'.',0 Restore table @SC86299 05227000 MVI TRTBL+C'(',0 @SC86299 05228000 LA 15,2 @SC86299 05229000 B FSPPTRS @SC86295 05230000 * 05230070 FSPBFIL LR 1,15 Length remaining @SC88070 05230140 SR 15,15 Set up just to pad @SC88070 05230210 FSPBPAD ICM 15,8,BLANK @SC88070 05230280 MVCL 0,14 Copy with blank fill @SC88070 05230350 BR 2 @SC88070 05230420 * 05230490 FSPFDOT LA 1,1(7) End of string @SC88070 05230560 LA 2,2 In case no breaks @SC86299 05230630 SR 7,6 @SC86299 05230700 EX 7,FSPTRT Find break @SC86299 05230770 AR 7,6 Restore ptr to last char @SC86299 05230840 BR 9 @SC88070 05230910 * 05231000 FSPH PTEXT 'Enter d.s.n[<first-last>]' @SC89261 05232000 CLI FSPFLG,FFSND SEND 1st? @SC89261 05232200 BE *+8 Yes, use whole message @SC89261 05232400 SH 4,=H'14' Chop off option part @SC89261 05232600 B FSP0H @SC86295 05233000 FSP2H PTEXT 'Enter foreign filespec' @SC86295 05234000 FSP0H LA 15,1 @SC86295 05235000 FSPPTRS RETREG 3,4 Return msg ptrs @SC86295 05236000 FSPRET RET , @SC86295 05238000 * 05239000 * Non-parsing functions . . . 05240000 * 05241000 * Get unique filespec 05242000 FSPWRN LR 4,1 Save name ptr @SC86295 05243000 TM FSPFLG,FFENC @SC86295 05244000 BO FSPENC Encode name into buffer @SC86295 05245000 TM FSPFLG,FFDSP @SC86295 05246000 BO FSPDSP Copy name into buffer for display @SC86295 05247000 TM FL4,NMOK Already checked? @SC87012 05248000 BO RTRN0 Yes, ok @SC87012 05249000 MVC XFILE,0(4) Save original name @SC90033 05249500 * This routine checks to see if the old data set is a PDS. @TS86001 05250000 * If so, it then allocates and opens the data set and does a @TS86001 05251000 * FIND to determine if the member is present. @TS86001 05252000 LA 5,10 Allowed retries (0-9) @SC88125 05253000 LA 7,C'0' Extra character @BS86001 05254000 MVC FSPDSN,0(4) @SC87015 05255000 BAL 9,FSPTOPN @SC87015 05256000 USING FDBD,1 @SC87015 05257000 CLI FSPDSMB,C' ' Member specified? @SC87015 05258000 BE FSPNOPDS No, be sure it isn't a PDS @SC87015 05259000 TM FDBFLGS,PDSF Yes, be sure it is @SC87015 05260000 BZ RTRN1 Too bad @SC87015 05261000 XC FSPDSMB,FSPDSMB Signal DSORG=PO for allocation @SC88119 05262000 OPENF I,FSPDSN,FILFDB,PDSPTR,E=FSPDERM @SC88049 05263000 MVC FSPDSMB,44(4) Copy requested member name @SC87015 05264000 LA 1,FSPDSMB+7 Last char of member @SC87015 05265000 TRT FSPDSMB,TRTBL Find blank @SC87015 05266000 LR 6,1 Tentative byte to modify @SC86299 05267000 BAL 3,FSPRMPT Set up rechecking via R3 @SC88125 05268000 FSPTFND L 1,PDSPTR @SC87015 05271000 FIND (1),FSPDSMB,D Search for member name @SC87015 05272000 B *+4(15) Branch on return code @TS86001 05273000 B 0(9) 0 - member was found @TS86001 05274000 B FSPNOKM 4 - member not found @TS86001 05275000 B FSPDERR 8 - I/O error or lack of memory @TS86001 05276000 FSPTOPN OPENF T,FSPDSN,E=FSPNOKD No collision @SC87015 05277000 BR 9 @SC87015 05278000 FSPNOPDS TM FDBFLGS,PDSF Be sure it isn't a PDS @SC87015 05279000 BO FSPDERM Too bad @SC88076 05280000 LA 3,FSPTOPN Just test DSN for existence @SC87015 05281000 MVI TRTBL+C'.',1 @SC87015 05282000 TRT FSPDSN(9),TRTBL Find end of 1st index @SC87015 05283000 LR 6,1 @SC87015 05284000 LA 1,8(6) Last possible end of 2nd @SC87015 05285000 TRT 2(7,6),TRTBL @SC87015 05286000 MVI TRTBL+C'.',0 Restore TRT @SC87015 05287000 LR 6,1 Byte to modify @SC87015 05288000 BZ FSPRMPT Index level was 8 bytes @SC87015 05289000 CLI FSPDSN+43,C' ' Exactly 44 bytes already? @SC88125 05289200 BE *+10 No, there's some room @SC88125 05289400 BCTR 6,0 Yes, can't shift name over @SC88020 05289600 B FSPRMPT @SC88020 05289800 LA 1,FSPDSN @SC87015 05290000 MVC 1(43,1),0(4) Shift name over one @SC87015 05291000 SR 6,1 @SC87015 05292000 EX 6,FSPMVDS And copy beginning back @SC87015 05293000 AR 6,1 @SC87015 05295000 FSPRMPT OI FL4,NMCHNG Yes, remember collision occurred @SC90033 05296000 CLI CLSNFL,C'O' Old-fashioned WARNING ON? @SC90033 05296600 BNE FSPSTA No, concoct unique name @SC90033 05297200 TM FSPFLG,FFGET User typed it? @SC87015 05298000 BO FSPRMP2 Yes @TS86001 05299000 FSPSTA STC 7,0(6) Modify DSN @SC88125 05300000 BALR 9,3 See if still a conflict @SC88125 05301000 LA 7,1(7) Bump counter @BS86001 05302000 BCT 5,FSPSTA @BS86001 05303000 FSPDERR CLOSF PDSPTR Close the data set @SC87015 05304000 FSPDERM PTEXT ' File name collision' @SC88049 05305080 L 1,EMSGP Explanatory message @SC88049 05305160 MVC 0(21,1),0(3) @SC88049 05305240 ST 4,EMSGL @SC88049 05305320 B FSP0H Return ptrs and rc=1 @SC88049 05305400 FSPMVDS MVC 0(,1),0(4) @SC88020 05305500 FSPNOKM MVC 44(8,4),FSPDSMB @SC87015 05306000 FSPNOKD MVC 0(44,4),FSPDSN Copy name back @SC87015 05307000 FSPNOK OI FL4,NMOK @SC87015 05308000 CLOSF PDSPTR @SC87015 05309000 B RTRN0 @SC87015 05310000 FSPRMP2 LA 7,CMD @SC87015 05311000 LA 0,FFDSP @SC87015 05312000 KCALL FSPEC,(4) Format DSN for message @SC87015 05313000 MVC 0(34,15),=C' exists. Reply "OK" to overwrite:' @SC87015 05314000 LA 3,34(15) @SC87015 05315000 SR 3,7 @SC87015 05316000 RTEXT (7),PROMPT=((7),(3)) @SC87268 05317000 LTR 0,0 Length of reply @SC87015 05318000 BNP FSPDERR If zero give up @SC88076 05319000 TR 0(2,7),UPCASE Upcase 1st 2 chars of reply @SC87015 05320000 CLC =C'OK',0(7) Was reply "ok"? @SC88076 05321000 BNE FSPDERR No, abort operation @SC88076 05322000 B FSPNOK @SC87015 05323000 * 05324000 * Encode name at (R1) into (R7) buffer (in ASCII), possibly with 05325000 * substitution from JFSPEC, but disable subsequent subst. 05326000 * Return updated ptr in R15 05327000 FSPENC LA 1,JFSPEC Complex string? @SC86224 05328000 BAL 14,PAKFOR @SC86224 05329000 BNZ FSPECPZ Yes, name overridden @SC86299 05330000 CLI 44(4),C' ' Member? @SC86299 05331000 BE FSPENT No, get name and type from DSN @SC86299 05332000 MVC 0(8,7),44(4) Yes, use member name @SC88070 05333000 LA 1,8(7) Possible end @SC88070 05333200 TRT 0(8,7),TRTBL Find end of name @SC88070 05333400 LR 5,1 Save @SC88070 05333600 BAL 9,FSPESCNS Find last DSN qualifier @SC88070 05333800 MVI 0(5),C'.' Join to member name @SC88070 05334000 MVC 1(8,5),0(3) Copy the qualifier @SC88070 05334200 SR 5,7 Length of member name @SC88070 05334400 LA 1,1(5,1) Adjust effective end of DSN @SC88070 05334600 B FSPENTR Done, convert to ASCII @SC88070 05334800 FSPENT BAL 9,FSPESCNS Find last qualifier @SC88070 05335000 BCTR 3,0 Move back to separating dot @SC88070 05335200 BAL 9,FSPESCN Back to previous qualifier @SC88070 05335400 MVC 0(17,7),0(3) At most 2 tokens + dot @SC86299 05335600 B FSPENTR Done, convert to ASCII @SC88070 05335800 * 05336000 FSPESCNS LA 1,44(4) @SC86299 05336200 TRT 0(44,4),TRTBL Find end of DSN @SC86299 05338000 LR 3,1 @SC86299 05340000 FSPESCN BCTR 3,0 Scan back for dots @SC86299 05341000 CR 3,4 Past beginning of DSN? @SC86299 05342000 BL FSPECP Yes, use all @SC86299 05343000 CLI 0(3),C'.' No, found dot? @SC86299 05344000 BNE FSPESCN No, keep looking @SC86299 05345000 FSPECP LA 3,1(3) Stuff to copy @SC86299 05347000 BR 9 @SC88070 05348000 FSPENTR DS 0H Translate and adjust ptr @SC88070 05348500 TR 0(17,7),ETOAD @SC89301 05349000 SR 1,3 Length of stuff copied @SC86299 05350000 AR 7,1 Advance ptr @SC86299 05351000 FSPECPZ MVI JFSPEC,0 Turn off string @SC86299 05352000 FSPENR LR 15,7 Save ptr @SC86295 05353000 B FSPRET @SC86295 05354000 * 05355000 * Copy name at (R1) into (R7) buffer in display form 05356000 * Return updated ptr in R15 05357000 FSPDSP LR 14,7 Copy output ptr @SC86299 05358000 LA 2,DEST Check if prefix exists @SC86299 05359000 LH 3,DESTL @SC86299 05360000 LTR 3,3 @SC86299 05361000 BZ FSPDCP No prefix, skip quotes @SC86299 05362000 LA 1,1(3) One extra for dot @SC86299 05363000 ICM 3,8,LOCASE+C'.' @SC86299 05364000 CLCL 0,2 Does it match prefix? @SC86299 05365000 BE FSPDCP Yes, chop it off @SC86299 05366000 LR 0,4 No, use quotes for whole name @SC86299 05367000 MVI 0(14),C'''' @SC86299 05368000 LA 14,1(14) @SC86299 05369000 FSPDCP LA 1,44(4) @SC86299 05370000 TRT 0(44,4),TRTBL Find end of name @SC86299 05371000 SR 1,0 Length @SC86299 05372000 LR 15,1 @SC86299 05373000 MVCL 14,0 Copy name to buffer @SC86299 05374000 CLI 44(4),C' ' Member name, too? @SC86299 05375000 BE FSPDCY No, done @SC86299 05376000 MVI 0(14),C'(' Yes, insert in parens @SC86299 05377000 MVC 1(8,14),44(4) Copy name to buffer @SC86299 05378000 LA 1,9(14) @SC86299 05379000 TRT 1(8,14),TRTBL Find end of member name @SC86299 05380000 MVI 0(1),C')' Close member name @SC86299 05381000 LA 14,1(1) @SC86299 05382000 FSPDCY LR 15,14 Return output ptr @SC86299 05383000 CLI 0(7),C'''' Need close quote? @SC86299 05384000 BNE *+12 No, that's all @SC86299 05385000 MVI 0(15),C'''' Yes, do it @SC86299 05386000 LA 15,1(15) @SC86299 05387000 B FSPRET @SC86299 05388000 * 05389000 * Insert '#' if token would otherwise begin with a digit @SC86299 05390000 FSPANAT LA 5,8 Tentative token length @SC86299 05391000 CLI 0(6),C'0' Digit? @SC86299 05392000 BLR 2 No, ok @SC86299 05393000 CLI 0(6),C'9' Really? @SC86299 05394000 BHR 2 No, but illegal anyway @SC86299 05395000 BAL 9,FSPTU Bad form @SC86299 05396000 LA 14,LOCASE+C'#' @SC86299 05397000 LA 1,1 @SC86299 05398000 MVCL 0,14 Copy '#' @SC86299 05399000 BCTR 5,0 Now allow only 7 @SC86299 05400000 BR 2 @SC86299 05401000 * 05402000 FSPTRSL DC XL256'00' For finding a '/' @SC88342 05402100 ORG FSPTRSL+C'/' @SC88342 05402200 DC X'1' @SC88342 05402300 ORG , @SC88342 05402400 * 05402500 * Valid DSN characters @SC86299 05403000 FSPTAB DC 64C'#',C' ' space @SC86299 05404000 DC 10C'#',C'.' dot @SC86299 05405000 DC 15C'#',C'$*' dollar sign, asterisk @SC86299 05406000 DC 03C'#',C'-' hyphen @SC86299 05407000 DC 26C'#',C'#@' pound sign, at sign @SC86299 05408000 DC 04C'#',C'ABCDEFGHI' a-i @SC86299 05409000 DC 07C'#',C'JKLMNOPQR' j-r @SC86299 05410000 DC 08C'#',C'STUVWXYZ' s-z @SC86299 05411000 DC 22C'#',C'{ABCDEFGHI' {,A-I @SC86299 05412000 DC 07C'#',C'JKLMNOPQR' J-R @SC86299 05413000 DC 08C'#',C'STUVWXYZ' S-Z @SC86299 05414000 DC 06C'#',C'0123456789' 0-9 @SC86299 05415000 DC 06C'#' @SC86299 05416000 * Valid member name characters @SC86299 05417000 FSPMTAB DC 75AL1(*-FSPMTAB),C'#' dot @SC86299 05418000 DC 20AL1(*-FSPMTAB),C'#' hyphen @SC88096 05420000 DC 95AL1(*-FSPMTAB),C'#' { @SC86299 05421000 DC 63AL1(*-FSPMTAB) @SC86299 05422000 * Replace asterisks if not a send request @SC88096 05422200 FSPSTAB DC 92AL1(*-FSPSTAB),C'#' asterisk @SC88096 05422400 DC 163AL1(*-FSPSTAB) @SC88096 05422600 LOCALS , @SC86295 05423000 PDSPTR DS A Ticket for PDS testing @SC87015 05424000 FSPDSN DS 0CL60 Temp for name field @SC88342 05425000 PDSNM DS CL44 Test DSN @SC87015 05426000 FSPDSMB DS CL8 Test member @SC87015 05427000 FSPPASS DS CL8 Password @SC88342 05427500 FSPFLG DS X Filespec flags @SC86295 05428000 FSPCH1 DS C Saved 1st char of spec. @SC88043 05428500 FSPEC EXIT @SC86295 05429000 TITLE 'KHELP routine - perform HELP command' 05430000 * Handle HELP command, rest of string given by SCANPTR. 05431000 * On entry, R6->help command string 05431500 KHELP ENTER , @SC86355 05432000 LR 8,6 Save ptr to command @SC88043 05433000 NTOKN N=KHLI See if subcommand given @SC86355 05434000 L 1,=A(USNCMD) Command table @SC87117 05435000 SCAN (1),KHLF,NODISP @SC86355 05436000 WTEXT 'Not a valid subcommand' Not found @SC86355 05437000 RET , @SC86355 05438000 KHLF CLM 7,8,F0 Just '?' @SC86355 05439000 BE RTRN Yes, done @SC86355 05440000 KHLI LM 6,7,SCANPTR Rest of string @SC88043 05441000 AR 6,7 Ptr to end @SC88043 05442000 LR 0,8 Start of command @SC88043 05443000 SR 6,0 Total length @SC88043 05444000 NI FL4,255-UCMD @SC88043 05445000 KCALL SUPFNC,3 Do it @SC86355 05448000 RET , @SC86355 05449000 LOCALS , 05450000 KHELP EXIT , @SC87007 05451000 TITLE 'SUPFNC Routine - various supervisor functions' @SC86158 05452000 SUPFNC ENTER @SC86295 05453000 * On entry, R1 = operation code, R0 = possible ptr @SC86158 05454000 * Exit: R15 set (0 => ok, <0 => illegal cmd, >0 => depends) 05455000 * ERRNUM set appropriately (R1=1,3,4) or unchanged (2,5-11) 05456000 * 1 -> Start typeout interception. N.B. &MAXLR >> 2048 for this 05457000 * 2 -> Clean up afterwards and stop interception 05458000 * 3 -> Execute host command with or without interception 05459000 * If UCMD set, SCANPTR gives text, else R0->text,R6=len 05460000 * 4 -> (not used) 05461000 * 5 -> Stop interception if going 05462000 * 6 -> Retrieve original cmd parm string into CBUF (R15=1 if null) 05463000 * 7 -> Test for stacked lines, return number in R15 05464000 * 8 -> Log off (must return to TMP) 05465000 * 9 -> Wait specified time 05466000 * 10-> Return clock time in R15 (centisec) 05467000 * 11-> Setup up new prompt string at (R0) 05468000 BCT 1,ICPFIN @SC86158 05469000 * Start interception, initialize ptrs @SC86158 05470000 MVI ERRNUM,ERRNOE OK @SC86158 05471000 LA 0,2048 Suitable offset @SC86158 05472000 A 0,WBUF Output buffer @SC86158 05473000 L 1,TSENT Limit @SC86158 05474000 LR 15,0 @SC86158 05475000 STM 15,0,TXTPTR Save @SC86158 05476000 STM 0,1,SVCOPTR @SC86158 05477000 SR 1,0 Get length @SC86158 05478000 L 15,=X'15000000' @SC86158 05479000 MVCL 0,14 Fill with NL (X'15') @SC86158 05480000 * ------------ determine if SVC screen is possible @SC88026 05480050 * - if so, then do it @SC88026 05480100 B ICPSTK @SC88026 05480150 MVI ICPFL,2 Now intercepting subtask SVC's @SC88026 05480200 B RTRN0 @SC88026 05480250 * Can't screen SVC's, create a STACK element @SC88026 05480300 ICPSTK OPENF T,STKDSN,E=ICPST2 See if any previous output @SC88026 05480350 USING FDBD,1 Yes, clear it @SC88106 05480400 SR 3,3 @SC88106 05480404 LA 4,FDBDEVT-2 Create volume list (n,type,vol) @SC88106 05480408 MVC 0(2,4),F1+2 Just one volume @SC88106 05480412 STM 2,4,SFCDEL+4 Simulate CAMLST @SC88106 05480416 MVI SFCDEL,X'0C' Code for UNCAT @SC88106 05480420 CATALOG SFCDEL @SC88106 05480424 MVI SFCDEL,X'41' Codes for SCRATCH @SC88106 05480428 MVI SFCDEL+2,X'40' @SC88106 05480432 SCRATCH SFCDEL @SC88106 05480436 DROP 1 @SC88106 05480440 ICPST2 LA 1,STKDSN Get ptrs to DYNALC arguments @SC88026 05480450 LA 2,STKDD @SC88026 05480500 LA 3,FILUNT @SC88026 05480550 LA 4,FILVOL @SC88026 05480600 LA 5,=X'42' NEW,CATLG @SC88026 05480650 LA 6,FILTRKAL @SC88026 05480700 LA 7,STKDRC @SC88026 05480750 STM 1,7,STKDYN Set up calling sequence @SC88026 05480800 OI STKDYN+24,X'80' No buffer ptr @SC88119 05480820 KCALL DYNALC,STKDYN,EXT Allocate output file @SC88026 05480850 MVI CPECB,0 Clear ECB (for neatness) @SC88076 05480870 STACK MF=(E,IOPLAREA),PARM=STKA Create STACK elt. @SC88026 05480900 MVI ICPFL,1 Now intercepting @SC87020 05481000 B RTRN0 @SC86295 05482000 * Clean up after interception @SC86295 05483000 ICPFIN BCT 1,ICPHST @SC86158 05484000 L 5,SVCOPTR End of text @SC86158 05485000 ST 5,TXTPTR+4 Save @SC86158 05486000 CLI ICPFL,2 Were we intercepting SVC's? @SC88026 05486040 BNE ICPFINST No, see if STACK @SC88026 05486080 *---------- stop snagging SVC's @SC88026 05486120 B ICPRST1 Ok @SC88026 05486160 ICPFINST CLI ICPFL,1 Were we intercepting via STACK? @SC88026 05486200 BNE ICPRST1 No, fine @SC88026 05486240 MVI CPECB,0 Clear ECB (for neatness) @SC88076 05486260 STACK MF=(E,IOPLAREA),PARM=STKZ Yes, remove STACK elt.@SC88026 05486280 * Copy output to buffer @SC88026 05486320 OPENF I,STKDSN,FILFDB,STKTKT,E=ICPRST1 @SC88026 05486360 L 3,STKTKT Ptr to FAB @SC88106 05486370 USING FABD,3 @SC88106 05486380 L 5,TXTPTR+4 Buffer ptr @SC88026 05486400 ICPSTLP READF STKTKT,BUFFER=(5),BSIZE=255,E=ICPSTZ @SC88026 05486440 TM FDBFLGS,FABRECCC Carriage control? @SC88246 05486450 BZ *+8 No, that's fine @SC88106 05486460 MVI 0(5),C' ' Yes, blank it out @SC88106 05486470 AR 5,0 Space over data @SC88026 05486480 LA 5,1(5) Leave one X'15' @SC88026 05486520 B ICPSTLP And read more @SC88026 05486560 ICPSTZ CLOSF STKTKT Done @SC88026 05486600 ST 5,TXTPTR+4 New end of output @SC88026 05486640 B ICPRST1 Now restore interrupts @SC86295 05487000 DROP 3 @SC88106 05487500 * Restore SVC interrupt vector @SC86158 05488000 ICPRST BCT 1,SFCLIN @SC86295 05489000 ICPRST1 MVI ICPFL,0 @SC87020 05490000 B RTRN0 05491000 * Execute TSO command at (R0) with length (R6), unless UCMD set, 05492000 * in which case string given by SCANPTR 05493000 ICPHST BCT 1,ICPCP @SC86158 05494000 TM FL4,UCMD User command? @SC86295 05495000 BO ICPCM0 Yes, scan already set up @SC86355 05496000 ICPCMI ST 0,ADR Set scan string ptrs @SC86355 05497000 ST 6,LEN @SC86355 05498000 ICPCM0 LM 0,1,SCANPTR Get length and adr @SC87034 05499000 LTR 6,0 Copy length @SC87034 05500000 BNP ICPCMIL No good @SC87034 05501000 BCTR 6,0 @SC87034 05502000 LA 5,0(6,1) Point to last character in string @GH89057 05502500 NTOKN N=ICPCMIL No good @SC86355 05504000 MVI SFCBUF+4,C' ' Initialize command buffer ... @GH89057 05505100 MVC SFCBUF+4+1(256-1),SFCBUF+4 ... to blanks @GH89057 05505200 SR 5,6 Compute decremented length ... @GH89057 05505300 MVC SFCBUF+4(*-*),0(6) Copy text to command buffer @GH89057 05505400 EX 5,*-6 ... and nothing else @GH89057 05505500 LR 5,6 Start of command name @SC86355 05506000 EX 7,TRUPCAS Capitalize command name @GH89112 05506500 LA 7,1(7) Length of name @SC86355 05507000 MVC EXCFLG,0(6) Copy 1st character (% if implicit)@SC89073 05507100 CLI 0(6),C'%' Is it implicit EXEC? @SC89073 05507200 BNE SFCCM1 No @SC89073 05507300 BCT 7,*+8 Yes, chop off '%' @SC89073 05507400 B ICPCMIL Oops, name was just '%' @SC89073 05507500 LA 6,1(6) @SC89073 05507600 SFCCM1 DS 0H @SC89073 05507700 ICM 7,8,BLANK Set up for padding @SC86355 05508000 L 2,ORGR1 Get address of kermit CPPL @TS86001 05509000 MVC ATCHCPPL(16),0(2) initialize attach CPPL @TS86001 05510000 LA 2,ATCHCPPL Get address of attach CPPL @TS86001 05511000 USING CPPL,2 Make attach CPPL addressable @TS86001 05512000 LA 1,SFCBUF @SC86355 05513000 ST 1,CPPLCBUF Put the command buffer into CPPL @TS86001 05514000 L 3,CPPLECT Get the ECT address @TS86001 05515000 USING ECT,3 Make it addressable @TS86001 05516000 MVC ECTPCMD,ORGPCMD Initialize, in case sub HELP @SC89052 05516500 LA 14,ECTSCMD @SC86355 05517000 LA 15,L'ECTSCMD @SC86355 05518000 MVCL 14,6 Copy to subcommand field @SC86355 05519000 CLM 7,7,F0 @SC88054 05519060 BNE ICPCMIL Command name longer than 8 @SC88054 05519120 CLI ECTSCMD,C'H' Is it HELP? @SC88043 05519200 BNE *+12 It's not subcommand help @SC88043 05519250 TM FL4,UCMD It might be (if generated) @SC88043 05519300 BZ *+10 ... yes, HELP as subcommand @SC88043 05519350 MVC ECTPCMD,ECTSCMD This is really a command @SC88026 05519600 LR 4,6 Default parameter ptr @SC86355 05520000 LR 8,6 Default end of string @SC86355 05521000 NTOKN N=SFCNPRM Find parameters, if any @SC86355 05522000 L 8,ADR @SC86355 05523000 A 8,LEN True end of string @SC86355 05524000 LR 4,6 Start of parameters @SC86355 05525000 SFCNPRM SR 4,5 Get offset to parameters @SC86355 05526000 STH 4,SFCBUF+2 Save in command buffer @SC86355 05527000 MVC SFCBLDL(4),=H'1,14' Set BLDL count & length @SC89073 05527500 SR 8,5 Get total length @SC86355 05528000 LA 8,4(8) Plus prefix info @SC88022 05529400 STH 8,SFCBUF Save in command buffer @SC86355 05530000 CLI EXCFLG,C'%' Check for explicit implicit clist @SC89073 05530030 BNE SFCLOCCP Try for a CP first @GH89056 05530060 SFCEXEC XC SFCBUF+2(2),SFCBUF+2 Indicate implicit clist @GH89056 05530090 CLC ECTSCMD,=CL8'EXEC' (Avoid looping) @GH89056 05530120 BE ICPCMIL This shouldn't happen! @GH89056 05530150 MVC SFCBLDL+4(8),ECTSCMD Copy into BLDL list @GH89050 05530180 ICM 1,15,SYSPROC Ptr to CLIST library DCB @SC89073 05530200 BZ ICPCMIL No such library @SC89073 05530220 BLDL (1),SFCBLDL @SC89073 05530240 LTR 15,15 @SC89073 05530260 BNZ ICPCMIL Couldn't find the CLIST @SC89073 05530280 MVC ECTPCMD,=CL8'EXEC' Ok, locate EXEC @GH89056 05530300 MVC ECTSCMD,=CL8'EXEC' @GH89056 05530320 SFCLOCCP DS 0H Come here to try again @GH89056 05530340 MVC SFCBLDL+4(8),ECTSCMD Copy into BLDL list @GH89050 05530400 BLDL 0,SFCBLDL Check for command to ATTACH @GH89050 05530500 LTR 15,15 Does command exist? @GH89050 05530600 BNZ SFCEXEC No: assume a CLIST @GH89056 05530700 STAX SFCATTN,DEFER=NO,REPLACE=NO,MF=(E,SFCSTBL), @SC88118+05531000 USADDR=ATCHECB In case subtask has no STAX @SC88118 05532000 ATTACH ECB=ATCHECB,DE=SFCBLDL+4,SHSPV=78,SZERO=NO, +05533000 MF=(E,(2)),SF=(E,ATCBLK) @SC86355 05534000 LTR 15,15 Was attach successful? @TS86001 05535000 BZ *+12 Ok @SC88118 05536000 BAL 14,SFCATCLN Restore everything @SC88118 05536200 B ICPCMIL No, must not exist @SC88026 05536400 ST 1,ATCHTCB Save TCB address @TS86001 05537000 WAIT ECB=ATCHECB Wait for subtask to finish @TS86001 05538000 LA 1,ATCTXP Set up req blk ptr to text list @SC88087 05538070 LA 4,ATCTXT Text list follows RB @SC88087 05538140 MVC 0(6,4),=H'1,1,4' Text unit type 1: TCB adr @SC88087 05538210 LA 5,ATCDRB RB ptr follows text list @SC88087 05538280 ST 1,ATCDRB+8 Fill in RB @SC88087 05538350 STM 4,5,ATCTXP Fill in text list + RB ptr @SC88087 05538420 MVI ATCTXP,X'80' Only item in text list @SC88087 05538490 MVC 0(2,5),=AL1(20,5) Finish up RB: length, type @SC88087 05538560 MVI ATCRBP,X'80' @SC88087 05538630 LA 1,ATCRBP @SC88087 05538700 SVC 99 DYNALLOC to free allocations @SC88087 05538770 DETACH ATCHTCB Detach the subtask @TS86001 05539000 BAL 14,SFCATCLN Restore everything @SC88118 05539500 SR 4,4 @SC86355 05540000 ICM 4,7,ATCHECB+1 Get return code @SC86355 05541000 * Issue return code msg if needed @SC86295 05544000 BZ SFCZRC RC=0 @SC86158 05546000 TM FL4,UCMD User cmd? @SC86316 05547000 BZ SFCZRC No, don't issue message @SC86316 05548000 MVC CMD(2),=C'R(' Set up message @SC86209 05549000 LA 15,CMD+2 @SC86209 05550000 BAL 2,EDDEC Edit RC into msg @SC86295 05551000 MVI 0(15),C')' Format is R(rc) @SC86209 05552000 LA 0,1(15) @SC86268 05553000 LA 1,CMD Start of edited string @SC86209 05554000 SR 0,1 Length @SC86268 05555000 WTEXT (1),(0) @SC86268 05556000 SFCZRC LR 15,4 @SC86295 05557000 MVI ERRNUM,ERRNOE No errors @SC86295 05558000 B RTRN @SC86295 05559000 * Unused, system-specific command type 05560000 ICPCP BCT 1,ICPRST @SC86158 05561000 ICPCMIL MVI ERRNUM,ERRSYS Illegal system command @SC86295 05562000 B RTRNM1 @SC86295 05563000 * 05563040 SFCATCLN STAX , Restore after ATTACH (saves R14) @SC88118 05563080 BR 14 @SC88118 05563160 * 05563200 SFCATTN STM 14,12,12(13) Save regs @SC88118 05563240 LR 3,15 @SC88118 05563280 USING SFCATTN,3 @SC88118 05563320 L 4,8(1) Ptr to ECB @SC88118 05563360 LA 2,4(4) Ptr to TCB @SC88118 05563400 TM 0(4),X'40' Already finished? @SC88118 05563440 BO SFCATTNR Yes, we just missed it @SC88118 05563480 STATUS STOP,TCB=(2) Suppress execution @SC88118 05563520 POST (4) No, so we just drop it @SC88118 05563560 SFCATTNR LM 14,12,12(13) Restore regs @SC88118 05563600 BR 14 @SC88118 05563640 DROP 3 @SC88118 05563680 * 05564000 SFCLIN BCT 1,SFCSTK @SC86295 05565000 * Retrieve original command line arguments, if any @SC86295 05566000 * Return code =0 if yes, =1 if no @SC86295 05567000 * Leave string in CBUF buffer (up to 256), length in CLEN @SC86295 05568000 L 2,ORGR1 Original R1 @SC86355 05569000 L 1,CPPLCBUF CBUF ptr @SC86355 05570000 LH 15,0(1) PARM length @SC86299 05571000 S 15,F4 @SC86299 05572000 LH 14,2(1) Parm offset @SC86355 05573000 SR 15,14 @SC86355 05574000 BNP RTRN1 Nothing there @SC86299 05575000 LA 14,4(14,1) Start of string @SC86299 05576000 L 0,CBUF @SC86299 05577000 LA 1,256 Max length allowed @SC86299 05578000 CR 1,15 @SC86299 05579000 BL *+6 @SC86299 05580000 LR 1,15 Shorter than max @SC86299 05581000 ST 1,CLEN @SC86299 05582000 MVCL 0,14 @SC86299 05583000 B RTRN0 @SC86295 05584000 * 05585000 * Test for stacked commands @SC86295 05586000 * return code = number of stacked lines @SC86295 05587000 SFCSTK BCT 1,SFCKIL @SC86295 05588000 LA 2,APGPB @NW86330 05589000 USING GTPB,2 @NW86330 05590000 ICM 1,15,GTPBIBUF Ptr to input buffer, if any @SC87015 05591000 BNZ RTRN1 Yes, line is stacked @SC87015 05592000 MVI CPECB,0 Clear ECB @SC88119 05592500 L 15,GETLINAD Entry point for GETLINE routine @NW86330 05593000 GETLINE PARM=(2),TERMGET=(EDIT,NOWAIT),ENTRY=(15), +05594000 MF=(E,IOPLAREA) @SC87015 05595000 C 15,F4 Check return code @SC87015 05596000 BNH RTRN1 Got one now @SC88095 05597000 MVC GTPBIBUF,F0 Clear it, just in case @SC88095 05597500 B RTRN0 Nothing stacked @SC88095 05598000 * 05599000 * Log out @SC86295 05600000 SFCKIL BCT 1,SFCWT @SC86295 05601000 LR 3,13 @SC88026 05602000 L 3,4(3) Look back through save areas @SC88026 05602100 CLC =A(USNTRF),16(3) Find main loop @SC89215 05602200 BNE *-10 @SC88026 05602300 L 3,8(3) Ptr to main save area @SC88026 05602400 OI KFLG-USNTRFSV(3),CMDC Set flag to quit @SC88026 05602500 PTEXT 'LOGOFF',AREG=0,LREG=6 @SC88026 05602600 NI FL4,255-UCMD Internal @SC86355 05603000 B ICPCMI Do it @SC86355 05604000 * 05605000 * Wait specified time in R0 (sec) 05606000 SFCWT BCT 1,SFCCLK @SC86295 05607000 MH 0,=H'100' Convert to centisec @SC86299 05608000 ST 0,TMPDW @SC86299 05609000 STIMER WAIT,BINTVL=TMPDW @SC86299 05610000 B RTRN0 @SC86295 05611000 * 05612000 * Return time in centisec in R15 05613000 SFCCLK BCT 1,SFCPRP @SC87351 05614000 STCK TMPDW Store TOD clock @SC86295 05615000 LM 14,15,TMPDW @SC86295 05616000 SLDL 14,8 Take mod 204 days @SC86295 05617000 SRDL 14,20 Get in microsec @SC86295 05618000 D 14,=F'10000' Get in centisec @SC86295 05619000 B RTRN @SC86295 05620000 * 05621000 SFCPRP B RTRN0 No action for prompting @SC87351 05622000 TITLE 'SVC interceptor, executed in system protect key' 05623000 USING ICPTYP,15 @SC86283 05624000 ICPTYP STM 12,14,SVCSV1 Save regs @SC86283 05625000 LR 13,15 Addressability @SC87020 05626000 DROP 15 05627000 USING ICPTYP,13 @SC87020 05628000 ICPTGO LM 14,15,SVCOPTR Output ptrs @SC86158 05629000 SR 15,14 Length left @SC86158 05630000 LA 12,255 Limit @SC86158 05631000 CLR 12,0 Buffer length @SC87020 05632000 BNH *+8 Too big @SC86158 05633000 LR 12,0 Ok, use it @SC87020 05634000 LTR 12,12 @SC86158 05635000 BNP ICPTRET @SC86283 05636000 CR 12,15 Enough room? @SC86283 05637000 BH ICPTRET No @SC86283 05638000 BCTR 12,0 Set up for mvc @SC86158 05639000 EX 12,SVCCOPY Move to WBUF @SC86158 05640000 LA 14,2(12,14) New end @SC86158 05641000 ST 14,SVCOPTR @SC86158 05642000 ICPTRET SR 15,15 Success @SC86283 05643000 LM 12,14,SVCSV1 Restore regs @SC86283 05644000 BR 14 Return @SC86283 05645000 SVCCOPY MVC 0(,14),0(1) @SC87020 05646000 * 05647000 * Storage for SVC interception @SC86158 05648000 SVCSV1 DS 2F Saved 12,13 @SC86158 05649000 SVCSV2 DS 2F Saved 14,15 @SC86158 05650000 SVCOPTR DS 2F Buffer output and end ptrs @SC86158 05651000 STKA STACK MF=L,DATASET=(*,OUTDD=STKDD) @SC88026 05651200 STKZ STACK MF=L,DELETE=TOP @SC88026 05651400 STKDD DC CL8'K999999Y' DD name for STACK interception @SC88026 05651600 LOCALS , @SC86295 05652000 ATCHCPPL DS 4F Subtask CPPL area @TS86001 05653000 SFCSTBL STAX MF=L ATTN during subtask execution @SC88118 05653500 ATCBLK ATTACH SF=L ATTACH parameter list @SC88022 05654000 ATCHECB DS F Subtask ECB @TS86001 05656000 DS 6X Leave some space for text unit @SC88291 05657000 ATCHTCB DS F Subtask TCB ptr @TS86001 05658000 ATCTXT EQU ATCHTCB-6,6 Prefix to TCB ptr (watch overlap!)@SC88087 05658500 SFCBUF DS F,CL256 Command buffer @GH89057 05659000 SFCBLDL DS 2H BLDL list: count & length @GH89050 05659030 DS CL8,XL52 BLDL list: membername, TTRC, etc. @GH89050 05659060 SFCDEL DS 0F CAMLST overlays... @SC88106 05659100 STKDYN DS 7F DYNALC calling sequence @SC88026 05659200 * - Also used for CAMLST UNCAT/SCRATCH & DYNALLOC@SC88106 05659300 STKDRC DS F DYNALC return code @SC88026 05659400 STKTKT DS A Ptr to STACK file FAB @SC88026 05659600 ORG STKDYN Overlay interception stuff @SC88087 05659660 ATCDRB DS 5F DYNALLOC RB (init to zeroes) @SC88087 05659720 ATCTXP DS A Text unit list (ATCTXT) @SC88087 05659780 ATCRBP DS A Ptr to RB @SC88087 05659840 ORG , @SC88087 05659900 EXCFLG DS C Flag for implicit EXEC @SC89073 05659950 SUPFNC EXIT @SC86158 05660000 TITLE 'TERMIO Routine - Handle terminal I/O' 05661000 * R1 points to a pair of (adr,len) for read or write. If I/O is 05662000 * successfull, R15 returns transferred byte count (else returns -1). 05663000 * Command code is in R0: 05664000 * 1 => Open line for I/O 4 => Write packet 05665000 * 2 => Close line 5 => Read packet 05666000 * 3 => Reset line status after ( 6 => Write message ) not used 05667000 * environment changes 05668000 * 05669000 TERMIO ENTER 05670000 SR 15,15 OK @SC86295 05671000 BCT 0,TRMCLS @SC86295 05672000 * Open terminal line for protocol 05673000 STAX BR14,REPLACE=NO Ingore attention interrupts @SC88118 05674490 MVI RIOC,X'80' Nothing saved @SC86295 05675000 MVI TRMFLG,X'FF' Initialize w/r flag @SC87275 05676000 B RTRN0 @SC86295 05677000 * Close terminal line after protocol transfer 05678000 TRMCLS BCT 0,TRMRSET @SC86295 05679000 STAX 05680000 B RTRN0 @SC86295 05681000 * (Re)set terminal characteristics to suit environment 05682000 TRMRSET BCT 0,TRMRW @SC86295 05683000 B RTRN0 @SC86295 05684000 * 05685000 * Perform I/O request 05686000 TRMRW BCT 0,TRMRD @SC87015 05687000 CLI WRRD,0 Write/read? @SC87275 05688000 BNE *+8 Yes @SC87275 05689000 MVI TRMFLG,0 Indicate no action on follow-up @SC87275 05690000 L 0,4(1) Get length @SC87015 05691000 L 1,0(1) and address @SC87015 05692000 ICM 1,8,=X'02' CONTROL @SC87317 05693000 CLI TRMTP,C'V' @SC88323 05693300 BE *+12 @SC88323 05693600 CLI TRMTP,C'F' @SC87317 05694000 BNE *+8 @SC87317 05695000 ICM 1,8,=X'03' FULLSCR (for VTAM) @SC88323 05696000 TPUT (1),(0),R Flags already set @SC87317 05697000 B RTRN0 @SC87317 05698000 * 05699000 * Read from terminal 05700000 TRMRD MVC KTGETT(8),0(1) Copy adr,len @SC87015 05701000 TS TRMFLG @SC87275 05702000 BZ RTRN0 Just a follow-up. 0-length read @SC87275 05703000 MVI ECBTGET,0 Clear ECB @SC87015 05704000 SR 5,5 Set flag 'no timing' @SC87015 05705000 ICM 5,1,TIMOSRV Timing allowed? @SC90045 05706000 BZ TRMPST @NW86330 05707000 ICM 5,1,TIMOUT Any timing requested? @SC87015 05708000 BZ TRMPST No, just wait @SC87015 05709000 MH 5,=H'100' @SC87015 05710000 ST 5,TMPDW @SC87015 05711000 LA 1,ECBTGET ECB for timer to post @SC88299 05712000 STCM 1,15,TMXPT Set up addressibility @SC88299 05712700 STIMER REAL,TMXIT,BINTVL=TMPDW @SC88299 05713400 TRMPST POST ECBREAD Tell async sub to go for it @NW86330 05714000 WAIT ECB=ECBTGET @NW86330 05715000 CLI ECBTGET+3,0 Check return code @NW86330 05716000 BNE TRMTIM @NW86330 05717000 LTR 5,5 Timing enabled? @SC87015 05718000 BZ TRMRET No, fine @SC87015 05719000 TTIMER CANCEL Yes, kill timer @SC87015 05720000 TRMRET L 15,KTGETT+4 Get length read @SC87015 05721000 B RTRN @SC87015 05722000 TRMTIM DETACH TASKADD Blow off task @NW86330 05723000 MVI ECBREAD,0 Zero out read ECB @NW86330 05724000 ATTACH EP=KERMTGET,MF=(E,COMPTR) @NW86330 05725000 ST 1,TASKADD Save adr for detach @NW86330 05726000 L 1,APKT Ptr to data buffer @SC87015 05727000 MVI 0(1),AT Timed out @SC87015 05728000 B RTRN1 Set count to one @SC87015 05729000 LOCALS , @SC86295 05738000 EXIT 05739000 TITLE 'KERMTGET Routine - Read from terminal (timed)' 05740000 * ECB's control timing flow @NW86330 05741000 KERMTGET CSECT @SC87015 05742000 USING *,12 @SC88299 05743000 SAVE (14,12),,* @SC87015 05744000 LR 12,15 @SC88299 05748000 LM 10,11,0(1) Set up addressibility @SC87015 05753000 KTGLP0 WAIT ECB=ECBREAD @NW86330 05760000 MVI ECBREAD,0 Zero ECB @NW86330 05761000 L 1,KTGETT Adr of buffer to put in @NW86330 05762000 L 0,KTGETT+4 Max TGET (although tcam's 4k) @NW86330 05763000 TGET (1),(0),ASIS @NW86330 05764000 LTR 15,15 @NW86330 05765000 BZ KTGLEN Ok @NW86330 05766000 C 15,F12 @NW86330 05767000 BE KTGLEN Ok @NW86330 05768000 SR 1,1 Error @NW86330 05769000 BCTR 1,0 @NW86330 05770000 KTGLEN ST 1,KTGETT+4 Save length @SC87015 05771000 POST ECBTGET Tell em we read it @NW86330 05772000 B KTGLP0 Keep repeating @NW86330 05773000 LTORG @SC87015 05774000 TITLE 'GETLIN Routine - Get a line from terminal' @SC87015 05776000 * Entry: R1->buffer of length 256 @SC87015 05777000 * Exit: Buffer filled, R0=length, R15=0 if ok. Else R15=1. @SC87015 05778000 GETLIN ENTER @SC87015 05779000 LR 8,1 Save buffer ptr @SC88095 05780000 LA 9,256 For copying @SC88095 05780800 LA 3,APGPB Ptr to GETLINE block @SC88095 05781600 USING GTPB,3 @SC88095 05782400 ICM 5,15,GTPBIBUF Already got something? @SC88095 05783200 BNZ GTL1 Yes, return it @SC87015 05784000 MVI CPECB,0 Clear ECB @SC88119 05784500 L 15,GETLINAD Entry point for GETLINE routine @NW86330 05785000 GETLINE PARM=(3),TERMGET=(EDIT,WAIT),ENTRY=(15), @SC88095+05786000 MF=(E,IOPLAREA) @SC87015 05787000 SR 2,2 @SC88095 05788000 C 15,F4 Problem? @SC87015 05789000 BH GTLA Yes, give up with len=0 @SC87015 05790000 L 5,GTPBIBUF Ptr to input buffer @SC88095 05791000 GTL1 LH 1,0(5) Length of stuff (inc. header) @SC88095 05791100 AR 1,5 End of buffer @SC88095 05791200 LR 0,1 Save end @SC88095 05791300 LH 6,2(5) Get starting offset (init. 0) @SC88095 05791400 LA 6,4(6,5) Ptr into buffer @SC88095 05791500 LR 2,1 @SC88095 05791600 SR 2,6 Length of text remaining @SC88095 05791700 BNP GTLFRE None, return length 0 @SC88095 05791800 SR 4,4 @SC88095 05791900 IC 4,LNDLM Get delimiter @SC88095 05792000 LA 4,TRTBL(4) Ptr to delimiter char @SC88095 05792100 MVI 0(4),1 Set up to snag delims @SC88095 05792200 MVI TRTBL+C' ',0 And ignore blanks @SC88095 05792300 CR 2,9 Get shorter of 256 and string @SC88095 05792400 BNH *+6 @SC88095 05792500 LR 2,9 @SC88095 05792600 BCTR 2,0 Set up for EX @SC88095 05792700 EX 2,GTLTRT @SC88095 05792800 MVI 0(4),0 Now clear out table @SC88095 05792900 MVI TRTBL+C' ',1 And restore @SC88095 05793000 SR 1,6 Length of line @SC88095 05793100 LR 7,1 Set up MVCL @SC88095 05793200 CR 9,7 Get shorter of 256 and string @SC88095 05793300 BNH *+6 @SC88095 05793400 LR 9,7 @SC88095 05793500 LR 2,9 Length actually copied @SC88095 05793600 MVCL 8,6 @SC88095 05793700 AR 6,7 In case we couldn't use it all @SC88095 05793800 CR 6,0 Finished input? @SC88095 05793900 BNL GTLFRE Yes, release it @SC88095 05794000 S 6,F3 + 1 - 4: skip over linend char @SC88095 05794100 SR 6,5 New offset ptr @SC88095 05794200 STH 6,2(5) @SC88095 05794300 B GTLZ Return @SC88095 05794400 GTLFRE LR 1,5 This buffer is used up @SC88095 05794500 LH 0,0(1) Get total length @SC88095 05794600 FREEMAIN RC,LV=(0),A=(1),SP=1 Free input buffer @NW86330 05800000 GTLA MVC GTPBIBUF,F0 Clear input indicator @SC87015 05801000 GTLZ RETREG (0,2) Return (2) as R0 @SC89218 05802000 B RTRN0 @SC87015 05805000 DROP 3 @SC88095 05806000 GTLTRT TRT 0(,6),TRTBL Find a delimiter @SC88095 05807000 LOCALS , @SC87015 05808000 GETLIN EXIT , @SC87015 05809000 TITLE 'SCRNIO Routine - Handle screen I/O via Series/1' 05810000 * R1 points to a pair of (adr,len) for read or write. If I/O is 05811000 * successfull, R15 returns transferred byte count (else returns -1). 05812000 * Command code is in R0: 05813000 * 0 => Clear screen on console (not comm line) @SC90045 05813500 * 1 => Open screen for I/O 4 => Write packet 05814000 * 2 => Close screen 5 => Read packet 05815000 * 3 => Reset screen status after 6 => Write message 05816000 * environment changes 05817000 * 05818000 SCRNIO ENTER 05819000 LTR 0,0 @SC90045 05819300 BZ SCRCLR @SC90045 05819600 BCT 0,SCRCLS @SC86295 05820000 * Set up for transparent I/O 05821000 MVI SCRLST,0 Clear op code @SC88091 05821100 STFSMODE ON,INITIAL=YES,NOEDIT=YES Full-screen mode @TS86001 05821200 SCRCLRA DS 0H @SC90045 05821300 TPUT CLRSPEC,CLRSPECL,FULLSCR Clear the screen @TS86001 05821600 B RTRN0 @SC86295 05822000 SCRCLR CLI TRMTP,C'T' Is it a TTY terminal? @SC90045 05822100 BE RTRN0 Yes, can't clear screen @SC90045 05822200 CLI TRMTP,C'V' Is it a TTY terminal? @SC90045 05822300 BE RTRN0 Yes, can't clear screen @SC90045 05822400 BE RTRN0 Yes, can't clear screen @SC90045 05822500 TM FL2,PROTO In protocol mode? @SC90045 05822600 BO RTRN0 Yes, skip clearing screen @SC90045 05822700 B SCRCLRA No, do it @SC90045 05822800 SCRCLS BCT 0,SCRRSET @SC86295 05823000 * Clean up after I/O 05824000 TPUT CLRSPEC,CLRSPECL,FULLSCR Clear the screen @TS86001 05824100 STFSMODE OFF @TS86001 05824200 B RTRN0 @SC86295 05825000 * (Re)set device characteristics to suit environment 05826000 SCRRSET BCT 0,SCRRW @SC86295 05827000 B RTRN0 05828000 * 05829000 * Perform I/O request 05830000 SCRRW LA 8,SCRPLST Get PLST ptr @SC88019 05831000 MVC 5(3,8),1(1) Copy adr @SC88019 05831400 MVC 2(2,8),6(1) Copy len @SC88019 05831800 SR 2,2 @SC88091 05831900 IC 2,SCRLST 1=>Write, 2=>Read, 3=>Wr. msg. @SC88091 05832000 STC 0,SCRLST Save new code @SC88091 05832100 BCT 0,SCRRD Different handling for each @SC88019 05832200 SCRWM DS 0H Come back here for message @SC88105 05832400 LR 1,8 WRITE: use new form of call @SC88019 05832600 MVI 4(8),X'03' Flags: FULLSCR/NOEDIT @SC88019 05833000 MVI 12(8),X'81' More flags: NOEDIT @SC88019 05833400 ICM 0,8,=X'80' Set hi bit of R0 @SC88019 05833800 SVC 93 Issue TPUT @SC88019 05834200 B RTRN0 Assume OK @SC88019 05834600 SCRRD BCT 0,SCRWM Go if "Write message" @SC88019 05835000 C 2,F3 Was last operation a Write msg? @SC88091 05835080 BNE SCRRD1 No, fine @SC88091 05835160 TPG =X'F6',1 Yes, must trigger a READ MOD @SC88091 05835240 SCRRD1 DS 0H @SC88091 05835320 MVI 4(8),X'81' Flags: TGET @SC88019 05835400 BAL 9,SCRNEX Execute internal subr @SC86295 05836000 TM FL1,DEBUG Logging in effect? @SC87286 05839000 BZ RTRN No, that's all @SC87286 05840000 TM DBGFLG,DBGIO I/O log wanted? @SC88168 05840300 BZ RTRN No, skip it @SC88168 05840600 L 2,LOGBUF Ptr to buffer @SC87286 05841000 MVI 0(2),C'A' Set label @SC87286 05842000 L 3,4(8) Ptr to AID @SC88019 05843000 MVC 2(3,2),0(3) Copy into buffer @SC87286 05844000 LR 9,15 Save data length @SC87286 05845000 WRITF LOGPTR,BSIZE=5 Log it @SC87286 05846000 TM DBGFLG,DBGSV Save log? @SC88168 05846200 BZ SCRIOLZ No, skip it @SC88168 05846400 SAVEF LOGPTR Yes, close it @SC88168 05846600 SCRIOLZ DS 0H @SC88168 05846800 LR 15,9 Return data length @SC87286 05847000 B RTRN Return @SC86299 05848000 * 05849000 SCRNEX LM 0,1,0(8) @SC88019 05850000 SVC 93 @SC86299 05852000 LR 15,1 Number of chars recv'd @SC86299 05853000 S 15,F3 Deduct AID length @SC88049 05853500 BR 9 @SC86299 05854000 * 05855000 CLRSPEC DC X'C2',AL1(SBA),X'4040',X'3C404000' Clear screen @TS86001 05856000 CLRSPECL EQU *-CLRSPEC Length of clear screen @TS86001 05857000 LOCALS , @SC86299 05860000 SCRPLST DS 4F Plist for TPUT/TGET @SC88019 05860500 SCRNIO EXIT , @SC86299 05861000 TITLE 'SETMSG Routine - controls CP breakin' 05862000 * Entry: R1 selects operation 05863000 * Exit: R15=0 if ok 05864000 * 1-> Analyze user environment, determine if suitable. 05865000 * Save quantities needed and condition line for entering commands. 05866000 * Perform any system-dependent initialization. 05867000 * 2-> Condition line for protocol transfers. 05868000 * 3-> Decondition line at end of transfer. 05869000 * 4-> System-dependent clean-up at exit. 05870000 * 5-> Reperform system-dependent initialization after SET LINE. 05871000 SETMSG ENTER , @SC87015 05872000 BCT 1,STM2 Go if R1 not 1, so no init 05873000 L 1,ORGR1 Get original R1 @SC86299 05874000 TM 0(1),X'80' Is this a command processor? @SC86299 05875000 BO NOTCP No, then refuse user @SC86299 05876000 USING CPPL,1 @SC86299 05877000 L 2,CPPLUPT Get ptr to UPT @SC86299 05878000 USING UPT,2 @SC86299 05879000 XR 3,3 @SC86299 05880000 IC 3,UPTPREFL Get length @SC86299 05881000 STH 3,DESTL Save for later @SC86299 05882000 MVC DEST(7),UPTPREFX Move prefix @SC86299 05883000 MVI DESTP,C' ' Not a PDS @SC86299 05884000 MVC OLDUPTSW,UPTSWS Save UPTSWS for later @TL89181 05884300 LA 4,IOPLAREA Get address of IOPL @TS86001 05885000 USING IOPL,4 Make it addressable @TS86001 05886000 MVC IOPLUPT,CPPLUPT Copy UPT ptr @TS86001 05887000 L 3,CPPLECT Copy ECT ptr @SC89052 05888000 ST 3,IOPLECT @SC89052 05888500 LA 0,CPECB Get address of ECB @TS86001 05889000 ST 0,IOPLECB Put into IOPL @TS86001 05890000 USING ECT,3 @SC89052 05890100 MVC ORGPCMD,ECTPCMD Save for Kermit HELP @SC89052 05890200 DROP 3,4 @SC89052 05890300 OPENF L,=C'SYSPROC ',,SYSPROC,E=STMS1 @SC89073 05890360 STMS1 DS 0H @SC89073 05890420 MVI TRMTP,C'&KCONT' 1st assume TTY @SC88309 05890500 GTSIZE , Get terminal info @SC86299 05899000 LTR 0,0 Is this a graphics device? @SC86299 05900000 BZ STMSTY No @SC86299 05901000 MVI TRMTP,C'S' Remember going via S/1 @SC87166 05902000 L 8,S1RDPL @SC88203 05902050 XC 0(9,8),0(8) Zero out buffer @SC88203 05902100 LA 0,1 @SC88203 05902150 KCALL SCRNIO Clear screen and set up @SC88203 05902200 LA 0,6 @SC88203 05902250 KCALL SCRNIO,STMS1ST Issue status request @SC88203 05902300 LA 0,5 @SC88203 05902350 KCALL SCRNIO,S1RDPL Read back status @SC88203 05902400 LA 0,2 @SC88203 05902450 KCALL SCRNIO Release screen @SC88203 05902500 CLI 0(8),X'E4' Check for Yale status response @SC88203 05902550 BE *+12 Ok, I trust @SC88294 05902600 CLI 0(8),0 Other possibility @SC88294 05902610 BNE STMGRP No, must be something else @SC88294 05902620 CLI 3(8),X'11' @SC88203 05902650 BNE STMGRP No, must be something else @SC88203 05902700 CLC =X'2B5B5B',6(8) @SC88203 05902750 BE STMOK Yes, all set @SC88203 05902800 STMGRP MVI TRMTP,C'G' Assume graphics device @SC88203 05902850 B STMOK @SC86299 05903000 STMSTY STSIZE SIZE=130 Set up linesize @TS86001 05904000 STCC ATTN Try PROFILE(ATTN) @GH89042 05904100 LTR 0,0 Check for LD=ATTN @GH89042 05904200 BM STMOK Must be TCAM TTY @GH89042 05904300 LA 15,X'FF' Set mask @GH89042 05904400 NR 15,0 Isolate old LD @GH89042 05904500 STCC LD=(15) Restore old LD @GH89042 05904600 LTR 0,0 Did first STCC work? @GH89042 05904700 BM STMOK Yes: must be TCAM TTY @GH89042 05904800 MVI TRMTP,C'V' No: must be VTAM TWX @GH89042 05904900 STMOK DS 0H @SC88042 05905000 * Note: KWRKBASE is 11... @SC89268 05905500 STM 10,11,COMPTR Save ptrs for KERMTGET @SC87015 05906000 LA 0,STKDSN Set up DSN for STACK @SC88026 05910030 LH 1,DESTL @SC88026 05910060 LA 2,DEST Get userid prefix @SC88026 05910090 LA 3,LFID @SC88026 05910120 MVCL 0,2 Copy prefix @SC88026 05910150 LR 1,3 @SC88026 05910180 LA 2,=CL8'.KER.BUF' @SC88026 05910210 LA 3,8 Copy rest of name @SC88026 05910240 ICM 3,8,BLANK Fill with blanks @SC88026 05910270 MVCL 0,2 @SC88026 05910300 LA 5,READATTN ATTN routine adr (just post ECB) @SC88118 05911000 LA 6,CPECB Ptr to ECB to post on ATTN @SC88118 05912000 STAX (5),MF=(E,STAXPLR),USADDR=(6) @SC88118 05913000 LOAD EP=IKJGETL Get line routine adr @NW86330 05917000 ST 0,GETLINAD Store it off @NW86330 05918000 LA 0,PTLLEN @SC88026 05918080 ST 0,PTPB+4 Set up PUTLINE parameter block @SC88026 05918160 LOAD EP=IKJPUTL PUTLINE routine adr @SC88026 05918240 ST 0,PUTLINAD @SC88026 05918320 L 5,=A(KERMTGET) Adr of TGET module @NW86330 05919000 PTEXT 'IDENTIFY failed.' Just in case @SC87015 05920000 IDENTIFY EP=KERMTGET,ENTRY=(5) @NW86330 05921000 LTR 15,15 @NW86330 05922000 BNZ SUBERR @SC87015 05923000 PTEXT 'ATTACH failed.' Just in case @SC87015 05924000 ATTACH EP=KERMTGET,MF=(E,COMPTR) @SC87015 05925000 LTR 15,15 @NW86330 05926000 BNZ SUBERR @SC87015 05927000 ST 1,TASKADD Save adr for detach @NW86330 05928000 B RTRN0 @SC86295 05929000 * 05929100 READATTN STM 14,12,12(13) Save registers @SC88118 05929200 L 1,8(1) Get ptr to term ECB @SC88118 05929300 POST (1) Post it @SC88118 05929400 LM 14,12,12(13) Restore registers @SC88118 05929500 BR 14 @SC88118 05929600 * 05930000 STM2 BCT 1,STM3 Go if R1 was not 2, so not off 05931000 CLI TRMTP,C'V' TTY terminals can't change hndshk @SC88323 05931300 BE *+12 @SC88323 05931600 CLI TRMTP,C'T' TTY terminals can't change hndshk @SC87343 05932000 BNE STM2X @SC87343 05933000 CLI S1HND,XON User wants special one anyway? @SC87343 05934000 BNE STM2X @SC87343 05935000 MVI S1HND,0 System provides the handshake @SC87343 05936000 STM2X DS 0H @SC87343 05937000 TM FL1,TSTF @SC86295 05938000 BO RTRN0 Just testing, don't change it @SC86295 05939000 CLI TRMLIN,C' ' Alternate comm line? @SC87300 05940000 BNE RTRN1 Not allowed! @SC87300 05941000 STCOM NO Set NOINTERCOM during protocol @TL89181 05941500 ICM 1,15,STMUOFF Turn off, just in case @SC88042 05942000 B STMD 05943000 * 05944000 STM3 BCT 1,STM4 @SC86316 05945000 TM OLDUPTSW,UPTNCOM Chk for NOINTERCOM in old UPT @TL89181 05945200 BO STM3A If so, leave it off @TL89181 05945400 STCOM YES Otherwise, set INTERCOM back on @TL89181 05945600 STM3A DS 0H @TL89181 05945800 ICM 1,3,STMUCH Restore user's settings @SC88042 05946000 ICM 1,12,STMUOFF Set flags to modify CDEL+LDEL @SC88042 05947000 STMD LA 0,7 @SC88042 05948000 SLL 0,24 Set entry code for STCC @SC88042 05949000 SVC 94 @SC88042 05950000 STC 0,STMUCH Save previous LDEL @SC88042 05951000 STC 1,STMUCH+1 and CDEL @SC88042 05952000 DROP 1,2 @SC88042 05953000 B RTRN0 05954000 * 05955000 STM4 BCT 1,STM5 Special clean-up @SC87351 05956000 DETACH TASKADD Kill sub-task @SC87296 05957000 CLOSF SYSPROC Close CLIST library @SC89073 05957500 B RTRN0 Special clean-up done @SC87296 05958000 * 05959000 STM5 B RTRN1 Other lines not allowed @SC87351 05960000 * 05961000 NOTCP PTEXT 'Kermit-TSO must be a command processor' @SC86299 05962000 TPUT (3),(4) Simplest output method... @SC88287 05963000 B RTRN1 @SC88287 05963500 * 05964000 STMUOFF DC X'3000FFFF' No char & line delete @SC88042 05965000 * 05965200 STMS1ST DC A(STMS1ORD,L'STMS1ORD) @SC88203 05965400 STMS1ORD DC X'F1C32B5BBC' WCC + Yale ASCII status request @SC88203 05965600 LOCALS , @SC86295 05966000 SETMSG EXIT 05967000 TITLE 'DISKIO Routine - performs disk I/O functions' 05968000 * ERRNUM unchanged unless there is a disk error 05968500 * Function selected on entry by R0: 05969000 * 0=> same as 9 (q.v.), but if ok, return R1->buffer,R0=# and remove 05969300 * the sequence number (if any) from the buffer (used for TAKE files) 05969600 * 1=> open (in): R1->pattern FDB, R2->name. Returns R0->FAB, R1->FDB 05970000 * 2=> open (out): (same) 05971000 * 3=> test name: R2->name. Returns R1->FDB if found (else R15=1) 05972000 * (will say "found" if member given, but it's not a PDS) @SC88043 05972200 * (will say "not found" if given member of PDS is missing) 05972400 * 4=> close file: R1->adr(FAB). 05973000 * 5=> set up search: R1->pattern name. 05974000 * 6=> return next file in list: Returns R1->FDB + sets up FILNAM 05975000 * 7=> close search (if any). 05976000 * 8=> test CWD string: R1->string. Returns R15=0 if ok, else =1. 05977000 * 9=> read: R1->FAB. Returns R15=12 if EOF, 0 if ok; R0=# data 05978000 * 10=> write: R1->FAB. Returns R15=13 if disk full, 0 if ok. 05979000 * 11=> test space: R1->pattern FDB (has size in Kbytes), 05980000 * R2->name (used if FAB not found), R6->adr(FAB). Return R15=0 if ok. 05980500 * 12=> analyze R/W error, set ERRNUM, make EMSG: R1->FAB, TMPDW=code 05981000 * always returns R15=1 05982000 * 13=> directory info on file: R1->name. Returns R15=0 if ok. 05983000 * 14=> delete file: R1->name. Returns R15=0 if ok. 05984000 * 15=> rename file: R1->name, R2->new name. Returns R15=0 if ok. 05985000 * 16=> copy file: R1->name, R2->new name. Returns R15=0 if ok. 05986000 * 21=> save file status in directory: R1->FAB. @SC88168 05986500 * 22=> open library (in): R2->DDNAME. Return R15=0 if ok. @SC89073 05986700 * 23=> point for next read, R1->adr(FDB), R2=records to skip. @SC89218 05986750 * Return R15=0 if ok. @SC89218 05986800 DISKIO ENTER 05987000 USING FABD,3 @SC86295 05988000 SR 4,4 Signal no block assigned @SC86295 05989000 STC 0,DSKCOD Save function code (for now) @SC88101 05989500 LA 5,DYNDSP @SC86345 05991000 LA 6,FDBTRKAL-FDBD(1) Use pattern TRKAL @SC88026 05992000 LA 7,DYNRC @SC86345 05993000 L 8,DFMSGP Ptr to message buffer @SC88119 05994000 XC 0(4,8),0(8) Clear out old message @SC88119 05994300 STM 5,8,DYNPL+16 Set up calling sequence @SC86345 05994600 LR 5,0 @SC89073 05995000 AR 5,5 @SC89073 05995080 LH 5,DSK0(5) Get handler address @SC89073 05995160 B DSK0(5) Do the function @SC89073 05995230 DSK0 DC Y(DSKRED-DSK0,DSKOPNI-DSK0,DSKOPNO-DSK0) 0-2 @SC89073 05995300 DC Y(DSKTEST-DSK0,DSKCLOS-DSK0,DSKNSET-DSK0) 3-5 @SC89073 05995370 DC Y(DSKNXT-DSK0,DSKXSET-DSK0,DSKCWDF-DSK0) 6-8 @SC89073 05995440 DC Y(DSKRED-DSK0,DSKWRT-DSK0,DSKTSP-DSK0) 9-11 @SC89073 05995510 DC Y(DSKXXX-DSK0),8Y(DSKUTL-DSK0) 12-20 @SC89073 05995580 DC Y(DSKTCLOS-DSK0,DSKOPLIB-DSK0) 21-22 @SC89073 05995650 DC Y(DSKPNT-DSK0) 23 @SC89218 05995720 DC 8Y(DSKER1-DSK0) Spares @SC89073 05995790 * 05996000 * Open for input file whose name is at (R2), FDB at (R1) 05997000 DSKOPNI DS 0H @SC89073 05997500 BAL 9,DSKALC Get FAB @SC86295 05998000 BAL 2,DSKLKP Get DSCB @SC86299 05999000 BNZ DSKER1 Not found @SC86295 06000000 BAL 14,DSKTCON Check PDS notation @SC88119 06000500 BAL 14,DSKVALS @SC86295 06001000 BAL 9,DSKFABS Set up FAB from FDB @SC86299 06002000 LH 0,FABLRECL @SC86299 06003000 CH 0,FDBBSIZ+2 Too big? @SC86299 06004000 BNL *+8 Yes, just read a buffer full @SC86299 06005000 ST 0,FDBBSIZ Set buffer size, in case RECFM=F @SC86299 06006000 B DSKOPT Open and test @SC88049 06009000 * 06011000 * Open for output file whose name is at (R2), FDB at (R1) 06012000 DSKOPNO DS 0H @SC89073 06013000 BAL 9,DSKALC Get FAB @SC86295 06014000 BAL 2,DSKLKP Get DSCB @SC86299 06016000 MVI DYNDSP,X'42' NEW,CATLG if not found @SC89250 06016500 BNZ DSKOPN Not found, just writing new @SC86299 06017000 BAL 14,DSKTCON Check PDS notation @SC88119 06017500 MVI DYNDSP,X'18' OLD,KEEP @SC86299 06018000 TM DS1DSO,2 PDS? @SC88083 06018300 BO DSKOPVA Yes, keep the other members! @SC88083 06018600 TM FDBFLGS,APPN @SC86295 06019000 BZ *+8 @SC90033 06020000 MVI DYNDSP,X'28' MOD,KEEP @SC88083 06020300 TM FDBFLGS,APPN+SVATT @SC90033 06020400 BZ DSKOPN @SC90033 06020500 DSKOPVA DS 0H @SC88083 06020600 BAL 14,DSKVALS @SC86295 06021000 BAL 9,DSKFABS Set up FAB from FDB @SC86299 06022000 DSKOPN MVI DSKOPLS,X'8F' Code for OPEN OUTPUT @SC88049 06024000 LH 0,FDBLRC @SC88120 06024200 BAL 2,DSKTV @SC88120 06024400 S 0,F4 Deduct 4 for RDW if RECFM=V @SC88120 06024600 ST 0,FABLRTR Set effective record length @SC88120 06024800 DSKOPT KCALL DYNALC,DYNPL,EXT @SC86299 06027000 CLI DYNRC+3,0 @SC88119 06027030 BNE DSKERAL Error on allocation @SC88119 06027060 CLI DYNDSP,X'42' NEW dataset? @SC88090 06027100 BNE DSKOPBZ No, assume BLKSIZE is ok @SC88090 06027200 DEVTYPE FABDDNAM,DYNPL Yes, get max block @SC88090 06027300 ICM 0,15,DYNPL+4 @SC88090 06027400 BNH DSKOPBZ Max not defined?? @SC88090 06027500 CH 0,FABBLKSI @SC88090 06027600 BNL DSKOPBZ Current BLKSIZE is ok @SC88090 06027700 STH 0,FABBLKSI Mustn't exceed physical limits! @SC88090 06027800 DSKOPBZ DS 0H @SC88090 06027900 OPEN MF=(E,DSKOPLS) @SC88049 06028000 TM FABOFLGS,X'10' @SC86299 06029000 BZ DSKER1 Didn't work @SC86299 06030000 B RTRN0 @SC86295 06031000 * 06032000 * Open library with DDNAME at (R2) - for BLDL only @SC89073 06032050 DSKOPLIB LR 8,2 @SC89073 06032100 LA 1,TAKFDB VB/256 @SC89073 06032150 LA 2,F0+FABDSN-FABDSMB DS=PO @SC89073 06032200 BAL 9,DSKALC Get a DCB @SC89073 06032250 MVC FABDDNAM,0(8) Use given DD name @SC89073 06032300 DMSFREE DWORDS=176/8,ERR=DSKER1 Get a JFCB @SC89073 06032350 LR 5,1 Save ptr to block @SC89073 06032400 ST 5,FABEXL Add to exit list @SC89073 06032450 MVI FABEXL,7 Mark it a JFCB @SC89073 06032500 RDJFCB MF=(E,DSKOPLS) @SC88073 06032550 LR 6,15 @SC89073 06032600 DMSFRET DWORDS=176/8,LOC=(5) @SC89073 06032650 LTR 15,6 @SC89073 06032700 BNZ DSKER1 @SC89073 06032750 MVI FABEXL,0 Disable JFCB ptr @SC89073 06032800 B DSKOPBZ Now open for input @SC89073 06032850 * 06032900 * Test for existence of file whose name is at (R2) 06033000 DSKTEST DS 0H @SC89073 06034000 LR 8,2 Save DSN ptr @SC89250 06035000 LA 1,FILFDB Default pattern for HRECALL @SC89250 06035300 BAL 9,DSKALC Allocate DCB @SC89250 06035600 BAL 2,DSKLKP Get DSCB @SC86299 06037000 BNZ DSKER1 Not found @SC86299 06038000 CLI FABDSMB,C' ' Did we want a member? @SC88119 06039000 BE DSKTE1 No, fine @SC88043 06039050 TM DS1DSO,2 Was it a PDS? @SC88043 06039100 BZ DSKTE1 No, ignore the conflict for now @SC88043 06039150 XC FABDSMB,FABDSMB Signal DSORG=PO @SC88119 06039200 OPENF I,FABDSN,FILFDB,DSKTKT,E=DSKER1 @SC89250 06039250 MVC FABDSMB,44(8) Restore member name @SC89250 06039270 L 1,DSKTKT @SC88043 06039300 FIND (1),FABDSMB,D See if member is there @SC89250 06039350 LR 5,15 Save return code @SC88043 06039400 CLOSF DSKTKT Close it up again @SC88043 06039450 LTR 5,5 @SC88043 06039500 BNZ DSKER1 Wasn't there @SC89250 06039550 DSKTE1 MVC DSKSTT+FDBD-FABD(FDBINFO),FDBD Save FDB stuff @SC89250 06039600 LA 0,FABDWDS Release FAB storage @SC89250 06039650 LR 1,3 @SC89250 06039700 DMSFRET DWORDS=(0),LOC=(1) @SC89250 06039750 SR 4,4 Mark it gone @SC89250 06039800 LA 3,DSKSTT Ptr for internal FDB @SC89250 06039850 BAL 14,DSKVALS Fill out FDB @SC89250 06039900 B RTRN0 @SC86299 06040000 * 06041000 * Close file whose ticket is at (R1), release block 06042000 DSKCLOS DS 0H @SC89073 06043000 ICM 3,15,0(1) Get FAB ptr, if any @SC86295 06044000 BZ RTRN0 None, ignore @SC86295 06045000 MVI 0(1),X'80' Flag for normal close @SC88049 06046000 LR 2,1 Save ptr @SC88049 06046400 CLOSE MF=(E,(1)) Close it @SC88049 06046800 XC 0(4,2),0(2) Ok, now clear ticket @SC88049 06047200 TM FABBUFCB+3,1 Any buffers? @SC88043 06047400 BO DSKFRPZ No, fine @SC88043 06047800 FREEPOOL (3) @SC86299 06048000 DSKFRPZ DS 0H Now free whole FAB @SC88043 06048500 LA 0,FABDWDS @SC86295 06049000 LR 1,3 @SC86299 06050000 DMSFRET DWORDS=(0),LOC=(1) @SC86295 06051000 B RTRN0 @SC86295 06052000 * 06052100 * TClose file whose ticket is in (R1) @SC88168 06052200 DSKTCLOS ST 1,DSKTKT @SC88168 06052300 MVI DSKTKT,X'80' Flag for normal close @SC88168 06052400 CLOSE MF=(E,DSKTKT),TYPE=T @SC88168 06052500 B RTRN0 @SC88168 06052600 * 06053000 * Read from file whose ticket is at (R1) 06054000 DSKRED DS 0H @SC89073 06055000 LTR 3,1 Get FAB ptr @SC86299 06056000 BNP RTRN1 Not defined anymore @SC86299 06057000 L 15,FABGET I/O routine @SC86299 06058000 BALR 14,15 Go to it @SC86299 06059000 LM 4,5,FDBBUFF Get buffer and size @SC86299 06060000 LH 7,FABLRECL Actual length @SC86299 06061000 LR 0,7 Save length for number check @SC88101 06061500 AR 7,1 End of record @SC86299 06062000 BAL 2,DSKTV @SC86299 06063000 LA 1,4(1) Skip over SDW if V @SC86299 06064000 CLI DSKCOD,0 NONUM? @SC88101 06064050 BNE DSKREDC No, use everything @SC88101 06064100 CLI FDBRCF,C'F' Fixed-length records? @SC88101 06064150 BNE DSKREDV No, line numbers at start (if any)@SC88101 06064200 CH 0,=H'80' See if F/80 @SC88101 06064250 BNE DSKREDC No @SC88101 06064300 MVZ CAMLOC(5),75(1) See if 76-80 are all numeric @SC88101 06064350 CLC CAMLOC(5),=8C'0' @SC88101 06064400 BNE DSKREDC No @SC88101 06064450 S 7,F8 Yes, move the end back @SC88101 06064500 B DSKREDC @SC88101 06064550 DSKREDV LA 0,8(1) Is length at least 8? @SC88101 06064600 CR 0,7 @SC88101 06064650 BNL DSKREDC No, can't be numbered @SC88101 06064700 MVZ CAMLOC(8),0(1) See if 1-8 all numeric @SC88101 06064750 CLC CAMLOC(8),=8C'0' @SC88101 06064800 BNE DSKREDC No, not numbered @SC88101 06064850 LA 1,8(1) Yes, skip over number @SC88101 06064900 DSKREDC DS 0H @SC88101 06064950 SR 7,1 Revised length @SC86299 06065000 LR 6,1 @SC86299 06066000 CR 7,5 @SC86299 06067000 BNL *+6 @SC86299 06068000 LR 5,7 Buffer not filled @SC86299 06069000 L 1,4(13) @SC86299 06070000 ST 5,20(1) Return length in R0 @SC86299 06071000 CLI DSKCOD,0 NONUM? @SC88101 06071200 BNE *+8 @SC88101 06071400 ST 4,24(1) Yes, return R1 ptr @SC88101 06071600 MVCL 4,6 Copy to buffer @SC86299 06072000 B RTRN0 @SC86299 06073000 * End of file on input. Don't close it yet. @SC86295 06074000 DSKEOD LA 15,12 End return code @SC86295 06075000 B RTRN @SC86295 06076000 * 06077000 * Write to file whose ticket is at (R1) 06078000 DSKWRT DS 0H @SC89073 06079000 LTR 3,1 Get FAB ptr @SC86299 06080000 BNP RTRN1 Not defined anymore @SC86299 06081000 LM 4,5,FDBBUFF Get buffer and size @SC86299 06082000 DSKWR1 LR 6,5 Copy for LRECL @SC88076 06086000 BAL 2,DSKTV @SC86299 06087000 LA 6,4(5) + 4 if RECFM=V @SC86299 06088000 STH 6,FABLRECL Set up for output @SC86299 06089000 IC 7,ERRNUM Save previous error code, if any @SC88139 06089500 MVI ERRNUM,0 Clear error number @SC86299 06090000 L 15,FABGET I/O routine @SC86299 06091000 BALR 14,15 Do it @SC86299 06092000 SR 15,15 @SC86299 06093000 ICM 15,1,ERRNUM See if deadly error @SC86299 06094000 BNZ RTRN Yes, pass return code @SC86299 06095000 STC 7,ERRNUM Restore previous error code @SC88139 06095500 XC 0(4,1),0(1) @SC86299 06096000 STCM 6,3,0(1) In case V @SC86299 06097000 BAL 2,DSKTV @SC86299 06098000 LA 1,4(1) V: space over SDW @SC86299 06099000 LR 6,1 @SC86299 06100000 LR 7,5 @SC86299 06101000 MVCL 6,4 Copy to output record @SC86299 06102000 B RTRN0 @SC86295 06103000 * 06103080 * Point past 1st N records of file at (R1) @SC89218 06103160 DSKPNT ICM 3,15,0(1) Get ticket @SC89218 06103240 BZ RTRN1 Not open @SC89218 06103320 LR 3,1 @SC89218 06103400 LTR 2,2 Number of records to skip @SC89218 06103480 BNP RTRN0 Never mind @SC89218 06103560 DSKPNTL READF 0(,3),E=RTRN1 Skip one @SC89218 06103640 BCT 2,DSKPNTL ... until finished @SC89218 06103720 B RTRN0 Return with completion code @SC89218 06103800 * 06104000 * Analyze error: packed dec. code in TMPDW 06105000 DSKXXX DS 0H @SC89073 06106000 MVI ERRNUM,ERRDIE Set Kermit error code @SC87338 06107000 L 2,EMSGP Ptr to msg buffer @SC87338 06108000 CLC =C' ',0(2) Proper SYNAD message? @SC87338 06109000 BE *+10 Yes, ok @SC87338 06110000 XC EMSGL,EMSGL No, clear length @SC87338 06111000 B RTRN1 @SC87338 06112000 * 06113000 * Disk utility for file(s) at (R1) and (R2) 06114000 DSKUTL LR 8,0 Save code-12 @SC86316 06115000 MVC DSKPSAV(8),DESTL+1 Save Kermit prefix @SC88043 06115100 L 14,ORGR1 Find User prefix @SC88043 06115200 USING CPPL,14 @SC88043 06115300 L 14,CPPLUPT @SC88043 06115400 USING UPT,14 @SC88043 06115500 MVC DESTL+1(1),UPTPREFL Use that for now @SC88043 06115600 MVC DEST(7),UPTPREFX @SC88043 06115700 DROP 14 @SC88043 06115800 SH 0,=H'13' Code-13: DIR,DEL,REN,COP @SC89073 06116000 SLA 0,3 @SC86295 06117000 LA 5,DSKCMDS @SC86295 06118000 AR 5,0 Ptr to command name @SC86295 06119000 LA 7,CMD Buffer for system command @SC86299 06120000 MVC 0(8,7),0(5) @SC86299 06121000 LA 7,8(7) @SC86299 06122000 LTR 0,0 Was it DIR? @SC88043 06122050 BNZ DSKUTP No, use filespec(s) as is @SC88043 06122100 MVC 0(4,7),=C'LVL(' Yes, maybe need an option @SC88043 06122150 MVC 4(44,7),0(1) If so, need whole filespec @SC88043 06122200 LA 0,4(7) @SC88043 06122250 LA 1,44 @SC88043 06122300 LA 14,DEST Comparand is user prefix @SC88043 06122350 LH 15,DESTL @SC88043 06122400 ICM 15,8,BLANK Extended with blanks @SC88043 06122450 CLCL 0,14 @SC88043 06122500 BE DSKUTX Just that - no options @SC88043 06122550 LA 1,4+44(7) @SC88043 06122600 TRT 4(44,7),TRTBL Find end of filespec @SC88043 06122650 MVI 0(1),C')' And complete the syntax @SC88043 06122700 LA 7,1(1) End of command string @SC88043 06122750 B DSKUTX Do it @SC88043 06122800 DSKUTP DS 0H Other utilities... @SC88043 06122850 BAL 3,DSKUTCP @SC86295 06123000 SRA 0,4 @SC86295 06124000 BZ *+10 @SC86295 06125000 LR 1,2 2nd file @SC86295 06126000 BAL 3,DSKUTCP @SC86295 06127000 DSKUTX MVC DESTL+1(8),DSKPSAV Restore Kermit prefix @SC88043 06127500 LA 0,CMD @SC86295 06128000 LR 6,7 @SC86299 06129000 SR 6,0 @SC86299 06130000 NI FL4,255-UCMD Not user command: adr=(0),len=(6) @SC86295 06131000 KCALL SUPFNC,3 Execute it @SC86295 06132000 B RTRN @SC86295 06133000 * 06134000 DSKUTCP LR 4,0 Save ID @SC86299 06135000 LA 0,FFDSP @SC86299 06136000 KCALL FSPEC @SC86299 06137000 MVI 0(15),C' ' @SC86299 06138000 LA 7,1(15) New output ptr @SC86299 06139000 LR 0,4 @SC86299 06140000 BR 3 @SC86295 06141000 * 06142000 DSKCMDS DC C'LISTCAT ' Utility command names @SC86299 06143000 DC C'DELETE ' @SC86299 06144000 DC C'RENAME ' @SC86299 06145000 DC C'COPY ' @SC86299 06146000 * 06147000 DSKTV TM FABRECFM,FABRECU @SC86299 06148000 BNM 4(2) U @SC86299 06149000 TM FABRECFM,FABRECF @SC86299 06150000 BO 4(2) F @SC86299 06151000 BR 2 V @SC86299 06152000 * Check PDS notation -- must match DSORG. Return via R14 06152090 DSKTCON TM DS1DSO,2 Partitioned? @SC88119 06152180 BO DSKTCOP Yes, insist on member name @SC88119 06152270 CLI FABDSMB,C' ' Member name? @SC88119 06152360 BER 14 No, ok @SC88119 06152450 B DSKER1 @SC88119 06152540 DSKTCOP CLI FABDSMB,C' ' Member name? @SC88119 06152630 BNER 14 Yes, ok @SC88119 06152720 CLI FABDSMB+1,0 No, but maybe just want directory?@SC88119 06152810 BER 14 Yes, ok @SC88119 06152900 * Return on error, release useless block, if any 06153000 DSKER1 LTR 1,4 Any block assigned? @SC86295 06154000 BZ RTRN1 No @SC86295 06155000 LA 0,FABDWDS Yes, release it @SC86295 06156000 DMSFRET DWORDS=(0),LOC=(1) @SC86295 06157000 B RTRN1 Flag error @SC86295 06158000 * 06158040 DSKERAL L 1,DFMSGP Ptr to DAIRFAIL buffer @SC88119 06158080 SR 9,9 @SC88119 06158120 ICM 9,3,0(1) Length of message @SC88119 06158160 BZ DSKER1 None (why not?) @SC88119 06158200 LA 8,4(1) Start of text @SC88119 06158240 CLC =C'IKJ',0(8) Has msg id? @SC88119 06158280 BNE *+8 @SC88119 06158320 LA 8,10(8) Yes, skip it @SC88119 06158360 S 8,F2 @SC88119 06158400 MVC 0(2,8),=C' ' Make it begin with two blanks @SC88119 06158440 AR 9,1 End of message @SC88119 06158480 SR 9,8 Length to use @SC88119 06158520 DSKERMSG L 6,EMSGP Explanation buffer @SC89250 06158560 LA 7,LEMSG Length of same @SC88119 06158600 CR 7,9 @SC88119 06158640 BNH *+6 @SC88119 06158680 LR 7,9 Too long, use what we can @SC88119 06158720 ST 7,EMSGL Usable length @SC88119 06158760 MVCL 6,8 Copy to buffer @SC88119 06158800 B DSKER1 @SC88119 06158840 * 06159000 DSKALC LR 5,1 Save FDB ptr @SC86295 06160000 LA 6,1 Update counter @SC86299 06161000 A 6,EVCTR @SC86299 06162000 ST 6,EVCTR @SC86299 06163000 LA 0,FABDWDS @SC86295 06164000 DMSFREE DWORDS=(0),ERR=DSKER1 @SC86295 06165000 LR 3,1 New block ptr @SC86295 06166000 ST 3,DSKOPLS Save for OPEN plist @SC88049 06166500 MVI DYNDSP,X'88' SHR,KEEP @SC86299 06166600 MVI DSKOPLS,X'80' Code for OPEN INPUT @SC88049 06166700 LA 4,FDBD FDB pointer @SC88120 06167000 RETREG (0,3),(1,4) Return FAB ptr in R0, FDB in R1 @SC89218 06168000 LR 4,3 Indicate we have it @SC88120 06169500 XC 0(8*FABDWDS,3),0(3) @SC86295 06170000 MVC FDBD(FDBCOP),0(5) Copy user's FDB @SC86295 06171000 MVC FABDSN,0(2) @SC86299 06173000 LA 15,FABDSN Set up DSN ptr @SC86299 06174000 LA 0,FABDDNAM Get DDN ptr @SC86299 06175000 LA 1,FDBUNT Get UNIT ptr @SC86299 06176000 LA 2,FDBVOL Get VOL ptr @SC86299 06177000 STM 15,2,DYNPL Set up DYNALC @SC86299 06178000 MVI FABBUFCB+3,1 Fill out DCB @SC86299 06179000 MVI FABDSORG,X'40' =PS @SC86299 06180000 MVI FABMACR,X'48' MACRF=GL @SC88043 06180500 CLI FABDSMB,0 Special case of PDS? @SC88119 06181000 BNE *+16 No @SC88043 06182000 MVI FABDSORG,X'02' Yes, set DSORG=PO @SC86299 06183000 MVI FABMACR,X'24' ... and MACRF=R @SC88043 06183500 MVI FABDSMB,C' ' and blot out member @SC88119 06184000 MVC FABMACR+1(1),FABMACR @SC88043 06184500 MVI FABIOBAD+3,1 @SC86299 06185000 LA 0,DSKEOD @SC86299 06186000 LA 1,FABEXL Modifiable exit list @SC89073 06187000 MVC 4(8,1),DSKOPEX Copy usual stuff into it @SC89073 06187500 STM 0,1,FABEODAD @SC86299 06188000 UNPK FABDDNAM,EVCTR(5) @SC86299 06189000 TR FABDDNAM,TRHEX Get unique DDNAME @SC86299 06190000 MVI FABDDNAM,C'K' @SC86299 06191000 MVI FABDDNAM+7,C'Z' @SC86299 06192000 MVI FABOFLGS,2 Not open yet @SC88043 06193000 MVI FABCHECK+3,1 @SC86299 06194000 LA 1,DSKSYN @SC87338 06195000 ST 1,FABSYNAD In case of error @SC86299 06196000 MVI FABIOBA+3,1 @SC86299 06197000 MVC FABEOBAD(16),FABIOBA @SC87314 06198000 MVI FABEOB+3,1 @SC86299 06199000 DSKFABS LH 1,FDBBLKSI Copy Info to DCB @SC88120 06200000 STH 1,FABBLKSI @SC88120 06200500 STH 1,FABLRECL @SC86299 06201000 MVI FABRECFM,FABRECU @SC86299 06203000 CLI FDBRCF,C'U' @SC86299 06204000 BE DSKFABCC @SC88246 06205000 MVC FABLRECL,FDBLRC Use true LRECL after all @SC88120 06205500 MVI FABRECFM,FABRECF+FABRECBR @SC86299 06206000 CLI FDBRCF,C'F' @SC86299 06207000 BE DSKFABCC @SC88246 06208000 MVI FABRECFM,FABRECV+FABRECBR @SC86299 06209000 DSKFABCC XC FABRECFM,FDBFLGS Copy carriage control flags @SC88246 06209400 NI FABRECFM,255-FABRECCC And only those flags @SC88246 06209800 XC FABRECFM,FDBFLGS @SC88246 06210200 BR 9 @SC86299 06212000 * 06213000 * Call with R15->name, return to R2 with CC set (Z if ok) 06214000 * Clobbers or sets 0,1,6,7,14,15. Assumes R3->full FAB @SC89250 06214300 * Assumes name ptr already stored in DYNPL, in case migrated @SC89250 06214600 DSKLKP SR 0,0 @SC86299 06215000 LA 1,CAMVOLS @SC86299 06216000 LA 14,X'44' Name code @SC86299 06217000 SLL 14,24 @SC86299 06218000 STM 14,1,CAMLOC Save dsn ptr, etc @SC86299 06219000 LA 0,CAMVOLS+6 @SC86299 06220000 LA 1,CAMDSCB @SC86299 06221000 LA 14,X'C1' Search code @SC86299 06222000 SLL 14,24 @SC86299 06223000 STM 14,1,CAMOBT @SC86299 06224000 LA 7,1 Flag for 1st pass @SC89250 06224300 DSKLKPL DS 0H @SC89250 06224600 LOCATE CAMLOC @SC86299 06225000 LTR 6,15 Retain 1st code in R6 @SC86299 06226000 BZ *+10 Ok, found it in catalog @SC88342 06227000 MVC CAMVOLS+6(6),FDBVOL Try default volume @SC88342 06227500 OBTAIN CAMOBT Get DSCB @SC86299 06228000 LA 0,=C'SYSALLDA' @SC88342 06229200 LA 1,FDBVOL In case not cataloged @SC88342 06229300 LTR 6,6 @SC88342 06229400 BNZ *+10 @SC88342 06229500 LA 0,=C' ' Cataloged, don't specify @SC88342 06229600 LR 1,0 @SC88342 06229700 STM 0,1,DYNPL+8 @SC88342 06229800 LTR 15,15 Test return code @SC89250 06229900 BZR 2 Ok, file was found @SC89250 06229940 LTR 6,6 @SC89250 06229980 BNZR 2 Quit if DSN wasn't in catalog @SC89250 06230020 BCT 7,DSKLKPZ Quit if already tried recall @SC89250 06230060 TM FL2,PROTO Transfer/server mode in progress? @SC89250 06230100 * BO DSKLKPZ Quit if in protocol mode @SC89250 06230140 CLC =C'MIGRAT',CAMVOLS+6 @SC89250 06230180 BNE DSKLKPZ Quit if volume not MIGRAT @SC89250 06230220 L 6,DYNPL Get ptr to name again @SC89250 06230260 MVC LKPMEM,44(6) Save member name, if any @SC89250 06230300 MVI 44(6),C' ' And blank it out @SC89250 06230340 KCALL DYNALC,DYNPL,EXT Set up DD @SC89250 06230380 MVC 44(8,6),LKPMEM Restore member name @SC89250 06230420 CLI DYNRC+3,0 @SC89250 06230460 BNE DSKER1 Quit if failed @SC89250 06230500 OPEN MF=(E,DSKOPLS) Open (and wait for recall) @SC89250 06230540 CLOSE MF=(E,DSKOPLS) Don't use, just close it @SC89250 06230580 TM FABBUFCB+3,1 @SC89250 06230620 BO DSKLKPL No buffers, all set @SC89250 06230660 FREEPOOL (3) Free buffers first @SC89250 06230700 B DSKLKPL Try all over again to LOCATE @SC89250 06230740 * 06231000 DSKLKPZ PTEXT ' Dataset not on-line',AREG=8,LREG=9 @SC89250 06231050 B DSKERMSG Copy msg to buffer @SC89250 06231100 * 06231150 * Handle synchronous disk I/O errors 06232000 DSKSYN SYNADAF ACSMETH=QSAM Get system to do the work @SC87338 06233000 L 2,EMSGP Ptr to msg buffer @SC87338 06234000 MVC 0(80,2),48(1) Copy message (inc. 2 blanks) @SC87338 06235000 LA 2,80 @SC87338 06236000 ST 2,EMSGL Length of string @SC87338 06237000 SYNADRLS Clean up @SC87338 06238000 B RTRN1 @SC87338 06239000 * 06240000 * Set up search through list of files, pattern at (R1) 06241000 DSKNSET DS 0H @SC89073 06242000 MVI CIROPT,2 Get full names @SC87015 06242200 L 3,CIRWA Initialize length ptrs @SC87015 06242400 MVC 0(4,3),CIRWAL @SC87015 06242600 NI DSKFL,255-WFN-NXDON @SC87015 06243000 MVC NXFN,0(1) Copy name @SC87015 06244000 LA 1,NXFN+52 End of member slot @SC88096 06244200 TRT NXFN+44(8),TRTBL Find end of member name @SC88096 06244400 LR 5,1 Save ptr @SC88096 06244600 LA 1,NXFN+44 @SC87015 06245000 TRT NXFN(44),TRTBL @SC87015 06246000 LR 3,1 End of name @SC87015 06247000 MVI TRTBL+C'*',1 @SC87015 06248000 LA 0,NXFN @SC88096 06248200 LA 9,DSKNDIR Where to go if no "*" in DSN @SC88096 06248400 LA 14,DSKNCIR Where to go if "*" found @SC88096 06248600 TRT NXFN(44),TRTBL Check for wild card @SC87015 06249000 DSKNSW BZR 9 Len=max, just use the one file @SC88096 06250000 CLI 0(1),C'*' Did we find an asterisk @SC87015 06252000 BNER 9 No, just the end of the name @SC88096 06253000 MVI TRTBL+C'*',0 @SC88096 06253500 OI DSKFL,WFN Mark it wild @SC87015 06254000 LA 4,1(1) @SC87015 06255000 ST 4,NXSFPTR Save ptr to suffix @SC87015 06256000 SR 3,4 @SC87015 06257000 STH 3,DSNSFL and length @SC87015 06258000 SR 1,0 @SC87015 06260000 STH 1,DSNPFL Length of prefix @SC87015 06261000 BR 14 Now get name list @SC88096 06261090 DSKNCIR CLI NXFN+44,C' ' Insist no members if wild DSN @SC88096 06261180 BNE RTRN1 @SC88096 06261270 AR 1,0 End of prefix string @SC88096 06261360 DSKNPLP BCTR 1,0 Scan back for a dot @SC88096 06261450 CR 1,0 Must be one, else we scan universe@SC88096 06261540 BNH RTRN1 None there, give up @SC88096 06261630 CLI 0(1),C'.' @SC88096 06261720 BNE DSKNPLP Keep looking @SC88096 06261810 SR 1,0 Count of bytes in whole qualifiers@SC88096 06261900 L 14,CIRSRCH Argument ptr @SC87015 06262000 LA 15,44 @SC87015 06263000 ICM 1,8,BLANK @SC87015 06264000 MVCL 14,0 Copy with blank fill @SC87015 06265000 LINK EP=IKJEHCIR,MF=(E,CIRPARM) Call catalog routine @NW86330 06266000 LTR 15,15 @SC87015 06267000 BNZ RTRN1 Not found @SC87015 06268000 LA 1,45-4 Skip count bytes, then back one @SC88096 06269000 DSKNRET L 2,CIRWA ADR OF RETURNED CATALOG BUFFER @SC88096 06269700 SR 2,1 Back up one item @SC88096 06270400 ST 2,CATDSPTR Save ptr to buffer @NW86330 06272000 B RTRN0 @SC86295 06273000 * 06273010 DSKNDIR LR 3,5 Use end of member name @SC88096 06273020 LA 0,NXFN+44 Start of member @SC88096 06273030 LA 9,RTRN0 Where to go if not wild @SC88096 06273040 TRT NXFN+44(8),TRTBL Find any '*' @SC88096 06273050 MVI TRTBL+C'*',0 Now restore table @SC88096 06273060 BAL 14,DSKNSW Return here if '*' found @SC88096 06273070 SR 4,4 Clear FAB ptr @SC88096 06273080 LA 1,DSKDPAT Sample DCB info @SC88096 06273090 LA 2,CAMVOLS Reuse this area for the DSN @SC88096 06273100 MVC 0(44,2),NXFN Copy DSN @SC88096 06273110 MVI 44(2),C' ' And blank out member @SC88096 06273120 BAL 9,DSKALC Get a DCB (FAB) @SC88096 06273130 BAL 2,DSKLKP Get DSCB @SC88096 06273140 BNZ DSKER1 Not found @SC89317 06273150 TM DS1DSO,2 Is it really a PDS? @SC88096 06273160 BZ DSKER1 No, give up @SC89317 06273170 KCALL DYNALC,DYNPL,EXT Allocate file @SC88096 06273190 OPEN MF=(E,DSKOPLS) And open it to the directory @SC88096 06273200 TM FABOFLGS,X'10' Ok? @SC88096 06273210 BZ DSKER1 Too bad @SC88096 06273220 ST 4,DSKTKT Save ptr to FAB @SC88096 06273230 L 2,CIRWA Start of name buffer @SC88096 06273240 LH 9,CIRWAL Length @SC88096 06273250 AR 9,2 End of buffer @SC88096 06273260 S 9,FDBBSIZ Back up one block @SC88096 06273270 DSKDL1 READF DSKTKT,BUFFER=(2),E=DSKDLZ Read a block @SC88096 06273280 SR 7,7 @SC88096 06273290 ICM 7,3,0(2) Get length of block info @SC88096 06273300 AR 7,2 End of block @SC88096 06273310 BCTR 7,0 Set up BXLE @SC88096 06273320 LA 8,2(2) Point to member info @SC88096 06273330 DSKDL2 CLC 0(8,8),=8X'FF' End of directory? @SC88096 06273340 BE DSKDLZ Yes, all done @SC88096 06273350 TM 11(8),X'80' Alias member? @SC88096 06273360 BO DSKDL3 Yes, ignore it @SC88096 06273370 MVI 0(2),C'A' Create table entry @SC88096 06273380 MVC 1(8,2),0(8) with member name @SC88096 06273390 LA 2,9(2) @SC88096 06273400 DSKDL3 IC 6,11(8) Get entry length @SC88096 06273410 N 6,=F'31' @SC88096 06273420 LA 6,12(6,6) In bytes @SC88096 06273430 BXLE 8,6,DSKDL2 On to next member @SC88096 06273440 CR 2,9 Room for another block in table? @SC88096 06273450 BNH DSKDL1 Ok @SC88096 06273460 DSKDLZ MVI 0(2),0 End of table @SC88096 06273470 CLOSF DSKTKT Release the file @SC88096 06273480 C 2,CIRWA Did we find anything? @SC88096 06273490 BE RTRN1 No?? @SC88096 06273500 LA 1,9 Length of entries @SC88096 06273510 B DSKNRET Go init. ptr into table @SC88096 06273520 DSKDPAT DC A(0,256),C'F',X'0',H'256,0,0,256' @SC88096 06273530 * 06274000 * Flush previous file pattern 06275000 DSKXSET DS 0H @SC89073 06276000 OI DSKFL,NXDON @SC87015 06277000 B RTRN0 @SC87015 06278000 * 06279000 * Check CWD string, return code in R15 06280000 DSKCWDF DS 0H @SC89073 06281000 MVC NXFN,0(1) Copy name @SC88054 06282000 LA 15,NXFN Temp name ptr @SC88054 06282500 LR 5,1 @SC87015 06283000 BAL 2,DSKLKP Check name @SC87015 06284000 BNZ RTRN0 No conflict, assume valid @SC88054 06285000 TM DS1DSO,2 Was a full DSN, check DSORG @SC88054 06286000 BO DSKCWD1 It's a PDS -- see if it matches @SC88054 06287000 CLI 44(5),C'.' PDS requested? @SC87015 06288000 BE RTRN1 Yes, but file not found @SC87015 06289000 B RTRN0 @SC88054 06290000 DSKCWD1 CLI 44(5),C'.' PDS requested? @SC87015 06292000 BNE RTRN1 No, but file was found @SC87015 06293000 B RTRN0 Yes, ok @SC87015 06294000 * 06295000 * Check disk space for proposed file: FDB at (R1), FAB ptr at (R6) 06296000 DSKTSP DS 0H @SC89073 06297000 * - - - get size of available space in R0,R1 @SC87015 06298000 LA 0,1023 For now, claim 4 Tbyte @SC87015 06299000 SRDA 0,10 Convert to Kbytes @SC86316 06300000 CLR 1,2 @SC87012 06301000 BL RTRN1 No room @SC86316 06302000 B RTRN0 Ok @SC86316 06303000 * 06304000 * Check against prefix and suffix criteria and return next match, 06306000 * if any 06307000 * Also return info in a File Descriptor Block @SC86151 06308000 DSKNXT DS 0H @SC89073 06308500 TM DSKFL,NXDON @SC87015 06309000 BO RTRN1 Nothing more @SC87015 06310000 MVC FILNAM,NXFN @SC87015 06310500 TM DSKFL,WFN Are we scanning? @SC87015 06311000 BO NXFBEG Yes, do it @SC87015 06312000 OI DSKFL,NXDON No, that's the only one @SC87015 06313000 LA 2,FILNAM @SC87015 06315000 B DSKTEST Now return file info @SC89157 06316000 NXFBEG L 6,CATDSPTR Ptr to place in catalog @NW86330 06317000 USING CATDSET,6 @NW86330 06318000 LA 7,NXFN+44 Start of member @SC88096 06319000 LA 8,8-1 Length of member name @SC88096 06319100 C 7,NXSFPTR Is suffix part of member name? @SC88096 06319200 BL *+12 Yes, we're set @SC88096 06319300 LA 7,NXFN No, use start of DSN @SC88096 06319400 LA 8,44-1 and length @SC88096 06319500 NXFDS LA 6,2(8,6) Next @SC88096 06319600 CLI TYPEBYTE,C'A' @NW86330 06320000 BNE NXFZ Assume end of list @SC87015 06321000 LH 2,DSNPFL Get prefix length @SC87015 06322000 LTR 2,2 @NW86330 06323000 BNP XL0092 @NW86330 06324000 LR 14,7 Compare saved prefix @SC88096 06325000 LA 3,CATDNAME against this name @SC87015 06326000 LA 5,0(2,3) End of possible match @SC87015 06327000 BCTR 2,0 Set up for CLC @SC87015 06328000 EX 2,NXFCMP @SC87015 06329000 BNE NXFDS No match @SC87015 06330000 XL0092 CLC DSNSFL,F0 @SC87015 06331000 BNH XL0002 Don't check suffix @NW86330 06332000 LA 1,1(8,3) Limit of name field @SC88096 06333000 EX 8,NXFTRT Find end of name @SC88096 06334000 LR 3,1 @SC87015 06335000 LH 4,DSNSFL @SC87015 06336000 SR 3,4 Ptr to start of suffix @SC87015 06337000 CR 3,5 @SC87015 06338000 BL NXFDS Shorter than prefix+suffix @SC88096 06339000 BCTR 4,0 @SC87015 06340000 L 14,NXSFPTR Ptr to comparison suffix @SC87015 06341000 EX 4,NXFCMP @SC87015 06342000 BNE NXFDS No match @SC87015 06343000 XL0002 SH 7,=Y(NXFN-FILNAM) Transpose into FILNAM @SC88096 06344000 EX 8,NXFCOP Copy DSN (or member) @SC88096 06345000 ST 6,CATDSPTR Save ptr for next time @NW86330 06347000 LA 2,FILNAM @SC87015 06348000 B DSKTEST Now return file info @SC89157 06349000 * 06350000 NXFCMP CLC 0(,3),0(14) @SC87015 06351000 NXFTRT TRT 0(,3),TRTBL Find end of name @SC88096 06351300 NXFCOP MVC 0(,7),CATDNAME Copy name @SC88096 06351600 * 06352000 NXFZ OI DSKFL,NXDON @SC87015 06353000 B RTRN1 Ran out of names @SC87015 06354000 * 06355000 DSKVALS LA 0,FDBD Ptr to FDB @SC86295 06356000 RETREG (1,0) Return FDB ptr as R1 @SC89218 06357000 NI FDBFLGS,255-PDSF @SC87015 06359000 TM DS1DSO,2 ORG=PO? @SC87015 06360000 BZ *+8 No @SC87015 06361000 OI FDBFLGS,PDSF Yes, it's a PDS @SC87015 06362000 SR 7,7 @SC87296 06363000 LA 15,DS1CRDT Assume creation date to be used @GH89270 06364000 CLI DS1MDDT,99 Is year plausible? @GH89270 06364040 BH DSKCRDT No - use creation date @GH89270 06364080 CLC DS1MDDT+1(2),=AL2(366) Is day of year plausible?@GH89270 06364120 BH DSKCRDT No - use creation date @GH89270 06364160 CLC DS1MDDT+1(2),=AL2(1) Is day of year plausible?@GH89270 06364200 BL DSKCRDT No - use creation date @GH89270 06364240 CLI DS1MDTM,X'23' Is hour plausible? @GH89270 06364280 BH DSKCRDT No - use creation date @GH89270 06364320 CLI DS1MDTM+1,X'59' Is minute plausible? @GH89270 06364360 BH DSKCRDT No - use creation date @GH89270 06364400 UNPK TMPDW,DS1MDTM(3) @GH89270 06364440 CLI TMPDW+4,C'9' Is 2nd hour digit ok? @GH89270 06364480 BH DSKCRDT No - use creation date @GH89270 06364520 CLI TMPDW+6,C'9' Is 2nd minute digit ok? @GH89270 06364560 BH DSKCRDT No - use creation date @GH89270 06364600 CLC DS1MDDT,DS1CRDT Is mod date before creation? @GH89270 06364640 BL DSKCRDT Yes - use creation date @GH89270 06364680 CLC DS1MDDT,DS1RFDT After latest ref? @GH89270 06364720 BH DSKCRDT Yes - use creation date @GH89270 06364760 MVC FDBDATE+4(2),DS1MDTM Copy hours, minutes @GH89270 06364800 LA 15,DS1MDDT Use modification date @GH89270 06364840 DSKCRDT IC 7,0(,15) Get year in binary @GH89270 06364880 CVD 7,TMPDW @SC87296 06365000 MVO FDBDATE+1(2),TMPDW Copy year @SC87296 06366000 ICM 7,3,1(15) Get day-of-year in binary @GH89270 06367000 MVC DSKMNTH,=AL1(30,31,30,31,31,30,31,30,31,28,31) @SC86299 06368000 TM 0(15),3 Check for leap year @GH89270 06369000 BNZ *+8 @SC87296 06370000 MVI DSKMNTH+9,29 Leap year, change Feb. @SC86299 06371000 LA 6,11 @SC86299 06372000 SR 0,0 @SC86299 06373000 DSKVMDL IC 0,DSKMNTH-1(6) @SC86299 06374000 SR 7,0 Test if passed the right month @SC86299 06375000 BNP DSKVMDM Got it @SC86299 06376000 BCT 6,DSKVMDL @SC86299 06377000 SR 0,0 Hit December @SC86299 06378000 DSKVMDM AR 7,0 Get day of month @SC86299 06379000 LCR 6,6 @SC86299 06380000 LA 6,12(6) Get month @SC86299 06381000 MH 6,=H'100' @SC86299 06382000 AR 6,7 Combine MMDD @SC86299 06383000 MH 6,=H'10' @SC86299 06384000 CVD 6,TMPDW @SC86299 06385000 MVC FDBDATE+2(2),TMPDW+5 @SC86299 06386000 * = = = = = get file size in bytes in R6,R7 - - - 06387000 SR 6,6 Return 0 for now (i.e., unknown) @SC87015 06388000 SR 7,7 @SC87015 06389000 AL 7,=F'1023' Round up @SC87007 06390000 BNO *+8 No overflow @SC86239 06391000 LA 6,1(6) @SC86239 06392000 SRDA 6,10 @SC86239 06393000 ST 7,FDBSIZE @SC86299 06394000 MVI FDBDATE,X'19' Assume 20th Cent @SC86295 06395000 CLI FDBDATE+1,X'50' @SC86295 06396000 BH *+8 Ok @SC86295 06397000 MVI FDBDATE,X'20' Must be 21st @SC86295 06398000 MVC FDBBLKSI,DS1BLK @SC86299 06399000 MVC FDBDEVT,CAMDEVT Copy device type @SC88106 06399500 MVC FDBVOL,CAMVOLS+6 Copy volume name @GH88319 06400000 XC FDBFLGS,DS1RCF Copy carriage control flags @SC88246 06400200 NI FDBFLGS,255-FABRECCC And only those flags @SC88246 06400400 XC FDBFLGS,DS1RCF @SC88246 06400600 LH 1,DS1BLK Use BLKSIZE if 'U' @SC86299 06401000 MVI FDBRCF,C'U' @SC86299 06402000 TM DS1RCF,FABRECU @SC86299 06403000 BO DSKVLR @SC86299 06404000 LH 1,DS1LRC Use LRECL if 'F' @SC86299 06405000 MVI FDBRCF,C'F' @SC86299 06406000 TM DS1RCF,FABRECF @SC86299 06407000 BO DSKVLR @SC86299 06408000 MVI FDBRCF,C'V' @SC86299 06409000 DSKVLR STH 1,FDBLRC @SC86299 06411000 L 7,4(13) Get previous stack frame @SC88048 06412000 L 1,4(7) and the one before @SC88076 06412100 CLC =A(SERVER),16(1) Was the caller SERVER? @SC89215 06412200 BE *+12 Yes, ok @SC88076 06412300 CLC =A(USNTRF),16(1) No, was it USNTRF? @SC89215 06412400 BNER 14 No, don't bother checking TAKE's @SC88076 06412500 USING SERVERSV,7 Assume SERVER or USNTRF @SC88048 06413000 ICM 0,15,TAKLEV Any TAKE files open? @SC88048 06414000 BNPR 14 No, that's fine @SC88048 06415000 CH 0,=Y(TAKMAX) Be sure this is valid @SC88048 06416000 BNLR 14 Oops, give up @SC88048 06417000 DSKVACT LR 6,0 @SC88048 06418000 SLA 6,2 @SC88048 06419000 L 6,TAKTAB-4(6) Fetch a file ticket @SC88048 06420000 CLC FABDSN,FABDSN-FABD(6) Does the name match? @SC88048 06421000 BE DSKVACS Yes, this file is in use @SC88048 06422000 BCT 0,DSKVACT No, keep looking @SC88048 06423000 BR 14 No match, that's ok @SC88048 06424000 DSKVACS OI FDBFLGS,FDBACTV Yes, turn on flag @SC88048 06425000 DROP 7 @SC88048 06426000 BR 14 @SC86299 06428000 * 06429000 DSKOPEX DC 0F'0',X'05',AL3(DSKOPC) OPEN EXIT @SC86299 06430000 DC X'91',AL3(DSKABEND) DCB ABEND exit @TS86001 06431000 * 06432000 * Look for x37 abends @TS86001 06433000 DSKABEND MVI ERRNUM,ERRFUL Assume full @SC86355 06434000 XC EMSGL,EMSGL Clear extra message @SC87338 06435000 CLC =X'B370',0(1) B37 abend? @TS86001 06436000 BE DSKABX Yes @SC86355 06437000 CLC =X'D370',0(1) D37 abend? @TS86001 06438000 BE DSKABX Yes @SC86355 06439000 CLC =X'E370',0(1) E37 abend? @TS86001 06440000 BE DSKABX Yes @SC86355 06441000 * Look for 013 abend @TS86001 06442000 MVI ERRNUM,ERRDIE Assume I/O error @SC86355 06443000 CLC =X'0130',0(1) 013 abend? @TS86001 06444000 BNE DSKABX No, assume worst @SC86355 06445000 CLI 2(1),X'14' Mismatch DSORG? @TS86001 06446000 BNE *+12 No @SC86355 06447000 MVI ERRNUM,ERRFNE Yes, member invalid or missing @SC86355 06448000 B DSKABX @SC86355 06449000 CLI 2(1),X'18' Unknown member name? @TS86001 06450000 BNE DSKABX No, assume worst @SC86355 06451000 MVI ERRNUM,ERRFNF Yes, say "not found" @SC86355 06452000 DSKABX MVI 3(1),X'04' Ignore if possible @SC86355 06453000 BR 14 Return @TS86001 06454000 * 06455000 DSKOPC LR 3,1 @SC86299 06456000 LH 5,FABBLKSI @SC86299 06457000 LTR 5,5 @SC86299 06458000 BP *+8 @SC86299 06459000 LH 5,=H'6233' @SC86299 06460000 LR 6,5 @SC86299 06461000 TM FABRECFM,FABRECU @SC86299 06462000 BO DSKOPS @SC86299 06463000 LH 6,FABLRECL @SC86299 06464000 BNZ *+8 @SC86299 06465000 OI FABRECFM,FABRECV+FABRECBR @SC86299 06466000 LTR 6,6 @SC86299 06467000 BP DSKOPQ @SC86299 06467500 LA 6,80 @SC86299 06468000 BAL 2,DSKTV @SC88049 06468500 LA 6,4(6) Allow LRECL=84 for VB @SC88049 06469000 DSKOPQ TM FABRECFM,FABRECF @SC86299 06469500 BZ DSKOPV @SC86299 06471000 SR 4,4 @SC86299 06472000 DR 4,6 @SC86299 06473000 LTR 5,5 @SC88104 06473200 BP *+8 @SC88104 06473400 LA 5,1 BLKSIZE was less than LRECL! @SC88104 06473600 MR 4,6 @SC86299 06474000 B DSKOPS @SC86299 06475000 DSKOPV LA 4,4(6) @SC86299 06476000 CR 4,5 @SC86299 06477000 BNH DSKOPS @SC86299 06478000 LR 5,4 @SC86299 06479000 DSKOPS STH 6,FABLRECL @SC86299 06480000 STH 5,FABBLKSI @SC86299 06481000 BR 14 @SC86299 06482000 * 06487000 DROP 6 @SC87015 06488000 * 06489000 LOCALS , @SC86295 06490000 DYNPL DS A(0,0,0,0,DYNDSP,0,DYNRC) @SC88026 06505000 DS A(0) Ptr to message buffer @SC88119 06506000 DYNRC DS F @SC86299 06507000 DSKTKT DS A Ptr for testing member @SC88043 06507500 DSKOPLS DS F Ptr to new FAB @SC88049 06507600 DYNDSP DS X @SC86299 06508000 DSKMNTH DS XL11 Month length table @SC86299 06509000 DSKPSAV EQU DSKMNTH,8 Buffer for saved prefix @SC88043 06509500 EXIT 06510000